module GF.Data.Operations (
Err(..), err, maybeErr, testErr, fromErr, errIn,
lookupErr,
ErrorMonad(..), checks,
liftErr,
checkUnique, unifyMaybeBy, unifyMaybe,
mapPairListM, mapPairsM, pairM,
BinTree, emptyBinTree, isInBinTree, --justLookupTree,
lookupTree, --lookupTreeMany,
lookupTreeManyAll, updateTree,
buildTree, filterBinTree,
mapTree, --mapMTree,
tree2list,
indent, (+++), (++-), (++++), (+++-), (+++++),
prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
topoTest, topoTest2,
ifNull,
combinations, done, readIntArg, --singleton,
iterFix, chunks,
) 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.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
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)
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
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
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
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)]
tree2list = Map.toList
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 +++- "" = a
a +++- b = a ++++ 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
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
combinations :: [[a]] -> [[a]]
combinations t = case t of
[] -> [[]]
aa:uu -> [a:u | a <- aa, u <- combinations uu]
topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
topoTest = topologicalSort . mkRel'
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
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)
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
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
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