forked from GitHub/gf-core
87e64a804c
+ Generalize the CommandInfo type by parameterizing it on the monad
instead of just the environment.
+ Generalize the commands defined in
GF.Command.{Commands,Commands2,CommonCommands,SourceCommands,HelpCommand}
to work in any monad that supports the needed operations.
+ Liberate GF.Command.Interpreter from the IO monad.
Also, move the current PGF from CommandEnv to GFEnv in
GF.Interactive, making the command interpreter even more generic.
+ Use a state monad to maintain the state of the interpreter in
GF.{Interactive,Interactive2}.
373 lines
10 KiB
Haskell
373 lines
10 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : Operations
|
|
-- Maintainer : AR
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/11/11 16:12:41 $
|
|
-- > CVS $Author: bringert $
|
|
-- > CVS $Revision: 1.22 $
|
|
--
|
|
-- some auxiliary GF operations. AR 19\/6\/1998 -- 6\/2\/2001
|
|
--
|
|
-- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL)
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Data.Operations (
|
|
-- ** The Error monad
|
|
Err(..), err, maybeErr, testErr, fromErr, errIn,
|
|
lookupErr,
|
|
|
|
-- ** Error monad class
|
|
ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
|
|
liftErr,
|
|
|
|
-- ** Checking
|
|
checkUnique, unifyMaybeBy, unifyMaybe,
|
|
|
|
-- ** Monadic operations on lists and pairs
|
|
mapPairListM, mapPairsM, pairM,
|
|
|
|
-- ** Binary search trees; now with FiniteMap
|
|
BinTree, emptyBinTree, isInBinTree, --justLookupTree,
|
|
lookupTree, --lookupTreeMany,
|
|
lookupTreeManyAll, updateTree,
|
|
buildTree, filterBinTree,
|
|
mapTree, --mapMTree,
|
|
tree2list,
|
|
|
|
-- ** Printing
|
|
indent, (+++), (++-), (++++), (+++++),
|
|
prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
|
|
prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
|
|
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
|
|
|
|
-- ** Topological sorting
|
|
topoTest, topoTest2,
|
|
|
|
-- ** Misc
|
|
ifNull,
|
|
combinations, done, readIntArg, --singleton,
|
|
iterFix, chunks,
|
|
{-
|
|
-- ** State monad with error; from Agda 6\/11\/2001
|
|
STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM,
|
|
-}
|
|
|
|
) where
|
|
|
|
import Data.Char (isSpace, toUpper, isSpace, isDigit)
|
|
import Data.List (nub, partition, (\\))
|
|
import qualified Data.Map as Map
|
|
import Data.Map (Map)
|
|
--import Control.Applicative(Applicative(..))
|
|
import Control.Monad (liftM,liftM2) --,ap
|
|
|
|
import GF.Data.ErrM
|
|
import GF.Data.Relation
|
|
|
|
infixr 5 +++
|
|
infixr 5 ++-
|
|
infixr 5 ++++
|
|
infixr 5 +++++
|
|
|
|
ifNull :: b -> ([a] -> b) -> [a] -> b
|
|
ifNull b f xs = if null xs then b else f xs
|
|
|
|
-- the Error monad
|
|
|
|
-- | Add msg s to 'Maybe' failures
|
|
maybeErr :: ErrorMonad m => String -> Maybe a -> m a
|
|
maybeErr s = maybe (raise s) return
|
|
|
|
testErr :: ErrorMonad m => Bool -> String -> m ()
|
|
testErr cond msg = if cond then done else raise msg
|
|
|
|
errIn :: ErrorMonad m => String -> m a -> m a
|
|
errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg))
|
|
|
|
lookupErr :: (ErrorMonad m,Eq a,Show a) => a -> [(a,b)] -> m b
|
|
lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs)
|
|
|
|
mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)]
|
|
mapPairListM f xys = mapM (\ p@(x,_) -> liftM ((,) x) (f p)) xys
|
|
|
|
mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
|
|
mapPairsM f xys = mapM (\ (x,y) -> liftM ((,) x) (f y)) xys
|
|
|
|
pairM :: Monad m => (b -> m c) -> (b,b) -> m (c,c)
|
|
pairM op (t1,t2) = liftM2 (,) (op t1) (op t2)
|
|
|
|
-- checking
|
|
|
|
checkUnique :: (Show a, Eq a) => [a] -> [String]
|
|
checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where
|
|
overloads = filter overloaded ss
|
|
overloaded s = length (filter (==s) ss) > 1
|
|
|
|
-- | this is what happens when matching two values in the same module
|
|
unifyMaybe :: (Eq a, Monad m) => Maybe a -> Maybe a -> m (Maybe a)
|
|
unifyMaybe = unifyMaybeBy id
|
|
|
|
unifyMaybeBy :: (Eq b, Monad m) => (a->b) -> Maybe a -> Maybe a -> m (Maybe a)
|
|
unifyMaybeBy f (Just p1) (Just p2)
|
|
| f p1==f p2 = return (Just p1)
|
|
| otherwise = fail ""
|
|
unifyMaybeBy _ Nothing mp2 = return mp2
|
|
unifyMaybeBy _ mp1 _ = return mp1
|
|
|
|
-- binary search trees
|
|
|
|
type BinTree a b = Map a b
|
|
|
|
emptyBinTree :: BinTree a b
|
|
emptyBinTree = Map.empty
|
|
|
|
isInBinTree :: (Ord a) => a -> BinTree a b -> Bool
|
|
isInBinTree = Map.member
|
|
{-
|
|
justLookupTree :: (ErrorMonad m,Ord a) => a -> BinTree a b -> m b
|
|
justLookupTree = lookupTree (const [])
|
|
-}
|
|
lookupTree :: (ErrorMonad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b
|
|
lookupTree pr x = maybeErr no . Map.lookup x
|
|
where no = "no occurrence of element" +++ pr x
|
|
|
|
lookupTreeManyAll :: Ord a => (a -> String) -> [BinTree a b] -> a -> [b]
|
|
lookupTreeManyAll pr (t:ts) x = case lookupTree pr x t of
|
|
Ok v -> v : lookupTreeManyAll pr ts x
|
|
_ -> lookupTreeManyAll pr ts x
|
|
lookupTreeManyAll pr [] x = []
|
|
|
|
updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b
|
|
updateTree (a,b) = Map.insert a b
|
|
|
|
buildTree :: (Ord a) => [(a,b)] -> BinTree a b
|
|
buildTree = Map.fromList
|
|
|
|
mapTree :: ((a,b) -> c) -> BinTree a b -> BinTree a c
|
|
mapTree f = Map.mapWithKey (\k v -> f (k,v))
|
|
|
|
filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b
|
|
filterBinTree = Map.filterWithKey
|
|
|
|
tree2list :: BinTree a b -> [(a,b)] -- inorder
|
|
tree2list = Map.toList
|
|
|
|
-- printing
|
|
|
|
indent :: Int -> String -> String
|
|
indent i s = replicate i ' ' ++ s
|
|
|
|
(+++), (++-), (++++), (+++++) :: String -> String -> String
|
|
a +++ b = a ++ " " ++ b
|
|
a ++- "" = a
|
|
a ++- b = a +++ b
|
|
a ++++ b = a ++ "\n" ++ b
|
|
a +++++ b = a ++ "\n\n" ++ b
|
|
|
|
prUpper :: String -> String
|
|
prUpper s = s1 ++ s2' where
|
|
(s1,s2) = span isSpace s
|
|
s2' = case s2 of
|
|
c:t -> toUpper c : t
|
|
_ -> s2
|
|
|
|
prReplicate :: Int -> String -> String
|
|
prReplicate n s = concat (replicate n s)
|
|
|
|
prTList :: String -> [String] -> String
|
|
prTList t ss = case ss of
|
|
[] -> ""
|
|
[s] -> s
|
|
s:ss -> s ++ t ++ prTList t ss
|
|
|
|
prQuotedString :: String -> String
|
|
prQuotedString x = "\"" ++ restoreEscapes x ++ "\""
|
|
|
|
prParenth :: String -> String
|
|
prParenth s = if s == "" then "" else "(" ++ s ++ ")"
|
|
|
|
prCurly, prBracket :: String -> String
|
|
prCurly s = "{" ++ s ++ "}"
|
|
prBracket s = "[" ++ s ++ "]"
|
|
|
|
prArgList, prSemicList, prCurlyList :: [String] -> String
|
|
prArgList = prParenth . prTList ","
|
|
prSemicList = prTList " ; "
|
|
prCurlyList = prCurly . prSemicList
|
|
|
|
restoreEscapes :: String -> String
|
|
restoreEscapes s =
|
|
case s of
|
|
[] -> []
|
|
'"' : t -> '\\' : '"' : restoreEscapes t
|
|
'\\': t -> '\\' : '\\' : restoreEscapes t
|
|
c : t -> c : restoreEscapes t
|
|
|
|
numberedParagraphs :: [[String]] -> [String]
|
|
numberedParagraphs t = case t of
|
|
[] -> []
|
|
p:[] -> p
|
|
_ -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t]
|
|
|
|
prConjList :: String -> [String] -> String
|
|
prConjList c [] = ""
|
|
prConjList c [s] = s
|
|
prConjList c [s,t] = s +++ c +++ t
|
|
prConjList c (s:tt) = s ++ "," +++ prConjList c tt
|
|
|
|
prIfEmpty :: String -> String -> String -> String -> String
|
|
prIfEmpty em _ _ [] = em
|
|
prIfEmpty em nem1 nem2 s = nem1 ++ s ++ nem2
|
|
|
|
-- | Thomas Hallgren's wrap lines
|
|
wrapLines :: Int -> String -> String
|
|
wrapLines n "" = ""
|
|
wrapLines n s@(c:cs) =
|
|
if isSpace c
|
|
then c:wrapLines (n+1) cs
|
|
else case lex s of
|
|
[(w,rest)] -> if n'>=76
|
|
then '\n':w++wrapLines l rest
|
|
else w++wrapLines n' rest
|
|
where n' = n+l
|
|
l = length w
|
|
_ -> s -- give up!!
|
|
|
|
--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id
|
|
|
|
-- | 'combinations' is the same as 'sequence'!!!
|
|
-- peb 30\/5-04
|
|
combinations :: [[a]] -> [[a]]
|
|
combinations t = case t of
|
|
[] -> [[]]
|
|
aa:uu -> [a:u | a <- aa, u <- combinations uu]
|
|
|
|
{-
|
|
-- | 'singleton' is the same as 'return'!!!
|
|
singleton :: a -> [a]
|
|
singleton = (:[])
|
|
-}
|
|
|
|
-- | Topological sorting with test of cyclicity
|
|
topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
|
|
topoTest = topologicalSort . mkRel'
|
|
|
|
-- | Topological sorting with test of cyclicity, new version /TH 2012-06-26
|
|
topoTest2 :: Ord a => [(a,[a])] -> Either [[a]] [[a]]
|
|
topoTest2 g0 = maybe (Right cycles) Left (tsort g)
|
|
where
|
|
g = g0++[(n,[])|n<-nub (concatMap snd g0)\\map fst g0]
|
|
|
|
cycles = findCycles (mkRel' g)
|
|
|
|
tsort nes =
|
|
case partition (null.snd) nes of
|
|
([],[]) -> Just []
|
|
([],_) -> Nothing
|
|
(ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest]
|
|
where leaves = map fst ns
|
|
|
|
|
|
-- | Fix point iterator (for computing e.g. transitive closures or reachability)
|
|
iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
|
|
iterFix more start = iter start start
|
|
where
|
|
iter old new = if (null new')
|
|
then old
|
|
else iter (new' ++ old) new'
|
|
where
|
|
new' = filter (`notElem` old) (more new)
|
|
|
|
-- | chop into separator-separated parts
|
|
chunks :: Eq a => a -> [a] -> [[a]]
|
|
chunks sep ws = case span (/= sep) ws of
|
|
(a,_:b) -> a : bs where bs = chunks sep b
|
|
(a, []) -> if null a then [] else [a]
|
|
|
|
readIntArg :: String -> Int
|
|
readIntArg n = if (not (null n) && all isDigit n) then read n else 0
|
|
|
|
{-
|
|
-- state monad with error; from Agda 6/11/2001
|
|
|
|
newtype STM s a = STM (s -> Err (a,s))
|
|
|
|
appSTM :: STM s a -> s -> Err (a,s)
|
|
appSTM (STM f) s = f s
|
|
|
|
stm :: (s -> Err (a,s)) -> STM s a
|
|
stm = STM
|
|
|
|
stmr :: (s -> (a,s)) -> STM s a
|
|
stmr f = stm (\s -> return (f s))
|
|
|
|
instance Functor (STM s) where fmap = liftM
|
|
|
|
instance Applicative (STM s) where
|
|
pure = return
|
|
(<*>) = ap
|
|
|
|
instance Monad (STM s) where
|
|
return a = STM (\s -> return (a,s))
|
|
STM c >>= f = STM (\s -> do
|
|
(x,s') <- c s
|
|
let STM f' = f x
|
|
f' s')
|
|
|
|
readSTM :: STM s s
|
|
readSTM = stmr (\s -> (s,s))
|
|
|
|
updateSTM :: (s -> s) -> STM s ()
|
|
updateSTM f = stmr (\s -> ((),f s))
|
|
|
|
writeSTM :: s -> STM s ()
|
|
writeSTM s = stmr (const ((),s))
|
|
-}
|
|
-- | @return ()@
|
|
done :: Monad m => m ()
|
|
done = return ()
|
|
|
|
class (Functor m,Monad m) => ErrorMonad m where
|
|
raise :: String -> m a
|
|
handle :: m a -> (String -> m a) -> m a
|
|
handle_ :: m a -> m a -> m a
|
|
handle_ a b = a `handle` (\_ -> b)
|
|
|
|
instance ErrorMonad Err where
|
|
raise = Bad
|
|
handle a@(Ok _) _ = a
|
|
handle (Bad i) f = f i
|
|
|
|
liftErr e = err raise return e
|
|
{-
|
|
instance ErrorMonad (STM s) where
|
|
raise msg = STM (\s -> raise msg)
|
|
handle (STM f) g = STM (\s -> (f s)
|
|
`handle` (\e -> let STM g' = (g e) in
|
|
g' s))
|
|
|
|
-}
|
|
|
|
-- | if the first check fails try another one
|
|
checkAgain :: ErrorMonad m => m a -> m a -> m a
|
|
checkAgain c1 c2 = handle_ c1 c2
|
|
|
|
checks :: ErrorMonad m => [m a] -> m a
|
|
checks [] = raise "no chance to pass"
|
|
checks cs = foldr1 checkAgain cs
|
|
{-
|
|
allChecks :: ErrorMonad m => [m a] -> m [a]
|
|
allChecks ms = case ms of
|
|
(m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs
|
|
_ -> return []
|
|
|
|
doUntil :: ErrorMonad m => (a -> Bool) -> [m a] -> m a
|
|
doUntil cond ms = case ms of
|
|
a:as -> do
|
|
v <- a
|
|
if cond v then return v else doUntil cond as
|
|
_ -> raise "no result"
|
|
-} |