diff options
Diffstat (limited to 'src/GF/Data/Operations.hs')
| -rw-r--r-- | src/GF/Data/Operations.hs | 559 |
1 files changed, 559 insertions, 0 deletions
diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs new file mode 100644 index 000000000..7110a7ac0 --- /dev/null +++ b/src/GF/Data/Operations.hs @@ -0,0 +1,559 @@ +module Operations where + +import Char (isSpace, toUpper, isSpace, isDigit) +import List (nub, sortBy, sort, deleteBy, nubBy) +import Monad (liftM2) + +infixr 5 +++ +infixr 5 ++- +infixr 5 ++++ +infixr 5 +++++ +infixl 9 !? + +-- some auxiliary GF operations. AR 19/6/1998 -- 6/2/2001 +-- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL) + +ifNull :: b -> ([a] -> b) -> [a] -> b +ifNull b f xs = if null xs then b else f xs + +-- the Error monad + +data Err a = Ok a | Bad String -- like Maybe type with error msgs + deriving (Read, Show, Eq) + +instance Monad Err where + return = Ok + Ok a >>= f = f a + Bad s >>= f = Bad s + +-- analogue of maybe +err :: (String -> b) -> (a -> b) -> Err a -> b +err d f e = case e of + Ok a -> f a + Bad s -> d s + +-- add msg s to Maybe failures +maybeErr :: String -> Maybe a -> Err a +maybeErr s = maybe (Bad s) Ok + +testErr :: Bool -> String -> Err () +testErr cond msg = if cond then return () else Bad msg + +errVal :: a -> Err a -> a +errVal a = err (const a) id + +errIn :: String -> Err a -> Err a +errIn msg = err (\s -> Bad (s ++++ "OCCURRED IN" ++++ msg)) return + +-- used for extra error reports when developing GF +derrIn :: String -> Err a -> Err a +derrIn m = errIn m -- id + +performOps :: [a -> Err a] -> a -> Err a +performOps ops a = case ops of + f:fs -> f a >>= performOps fs + [] -> return a + +repeatUntilErr :: (a -> Bool) -> (a -> Err a) -> a -> Err a +repeatUntilErr cond f a = if cond a then return a else f a >>= repeatUntilErr cond f + +repeatUntil :: (a -> Bool) -> (a -> a) -> a -> a +repeatUntil cond f a = if cond a then a else repeatUntil cond f (f a) + +okError :: Err a -> a +okError = err (error "no result Ok") id + +isNotError :: Err a -> Bool +isNotError = err (const False) (const True) + +showBad :: Show a => String -> a -> Err b +showBad s a = Bad (s +++ show a) + +lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err b +lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs) + +lookupErrMsg :: (Eq a,Show a) => String -> a -> [(a,b)] -> Err b +lookupErrMsg m a abs = maybeErr (m +++ "gave unknown" +++ show a) (lookup a abs) + +lookupDefault :: Eq a => b -> a -> [(a,b)] -> b +lookupDefault d x l = maybe d id $ lookup x l + +updateLookupList :: Eq a => (a,b) -> [(a,b)] -> [(a,b)] +updateLookupList ab abs = insert ab [] abs where + insert c cc [] = cc ++ [c] + insert (a,b) cc ((a',b'):cc') = if a == a' + then cc ++ [(a,b)] ++ cc' + else insert (a,b) (cc ++ [(a',b')]) cc' + +mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)] +mapPairListM f xys = + do yy' <- mapM f xys + return (zip (map fst xys) yy') + +mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] +mapPairsM f xys = + do let (xx,yy) = unzip xys + yy' <- mapM f yy + return (zip xx yy') + +pairM :: Monad a => (b -> a c) -> (b,b) -> a (c,c) +pairM op (t1,t2) = liftM2 (,) (op t1) (op t2) + +-- like mapM, but continue instead of halting with Err +mapErr :: (a -> Err b) -> [a] -> Err ([b], String) +mapErr f xs = Ok (ys, unlines ss) + where + (ys,ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs]) + fxs = map f xs + +-- !! with the error monad +(!?) :: [a] -> Int -> Err a +xs !? i = foldr (const . return) (Bad "too few elements in list") $ drop i xs + +errList :: Err [a] -> [a] +errList = errVal [] + +singleton :: a -> [a] +singleton = (:[]) + +-- 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 + +titleIfNeeded :: a -> [a] -> [a] +titleIfNeeded a [] = [] +titleIfNeeded a as = a:as + +errMsg :: Err a -> [String] +errMsg (Bad m) = [m] +errMsg _ = [] + +errAndMsg :: Err a -> Err (a,[String]) +errAndMsg (Bad m) = Bad m +errAndMsg (Ok a) = return (a,[]) + +-- a three-valued maybe type to express indirections + +data Perhaps a b = Yes a | May b | Nope deriving (Show,Read,Eq,Ord) + +yes = Yes +may = May +nope = Nope + +mapP :: (a -> c) -> Perhaps a b -> Perhaps c b +mapP f p = case p of + Yes a -> Yes (f a) + May b -> May b + Nope -> Nope + +-- this is what happens when matching two values in the same module +unifPerhaps :: Perhaps a b -> Perhaps a b -> Err (Perhaps a b) +unifPerhaps p1 p2 = case (p1,p2) of + (Nope, _) -> return p2 + (_, Nope) -> return p1 + _ -> Bad "update conflict" + +-- this is what happens when updating a module extension +updatePerhaps :: b -> Perhaps a b -> Perhaps a b -> Err (Perhaps a b) +updatePerhaps old p1 p2 = case (p1,p2) of + (Yes a, Nope) -> return $ may old + (May older,Nope) -> return $ may older + (_, May a) -> Bad "strange indirection" + _ -> unifPerhaps p1 p2 + +-- binary search trees + +data BinTree a = NT | BT a (BinTree a) (BinTree a) deriving (Show,Read) + +isInBinTree :: (Ord a) => a -> BinTree a -> Bool +isInBinTree x tree = case tree of + NT -> False + BT a left right + | x < a -> isInBinTree x left + | x > a -> isInBinTree x right + | x == a -> True + +-- quick method to see if two trees have common elements +-- the complexity is O(log |old|, |new|) so the heuristic is that new is smaller + +commonsInTree :: (Ord a) => BinTree (a,b) -> BinTree (a,b) -> [(a,(b,b))] +commonsInTree old new = foldr inOld [] new' where + new' = tree2list new + inOld (x,v) xs = case justLookupTree x old of + Ok v' -> (x,(v',v)) : xs + _ -> xs + +justLookupTree :: (Ord a) => a -> BinTree (a,b) -> Err b +justLookupTree = lookupTree (const []) + +lookupTree :: (Ord a) => (a -> String) -> a -> BinTree (a,b) -> Err b +lookupTree pr x tree = case tree of + NT -> Bad ("no occurrence of element" +++ pr x) + BT (a,b) left right + | x < a -> lookupTree pr x left + | x > a -> lookupTree pr x right + | x == a -> return b + +lookupTreeEq :: (Ord a) => + (a -> String) -> (a -> a -> Bool) -> a -> BinTree (a,b) -> Err b +lookupTreeEq pr eq x tree = case tree of + NT -> Bad ("no occurrence of element equal to" +++ pr x) + BT (a,b) left right + | eq x a -> return b -- a weaker equality relation than == + | x < a -> lookupTreeEq pr eq x left + | x > a -> lookupTreeEq pr eq x right + +lookupTreeMany :: Ord a => (a -> String) -> [BinTree (a,b)] -> a -> Err b +lookupTreeMany pr (t:ts) x = case lookupTree pr x t of + Ok v -> return v + _ -> lookupTreeMany pr ts x +lookupTreeMany pr [] x = Bad $ "failed to find" +++ pr x + +-- destructive update + +updateTree :: (Ord a) => (a,b) -> BinTree (a,b) -> BinTree (a,b) +updateTree = updateTreeGen True + +-- destructive or not + +updateTreeGen :: (Ord a) => Bool -> (a,b) -> BinTree (a,b) -> BinTree (a,b) +updateTreeGen destr z@(x,y) tree = case tree of + NT -> BT z NT NT + BT c@(a,b) left right + | x < a -> let left' = updateTree z left in BT c left' right + | x > a -> let right' = updateTree z right in BT c left right' + | otherwise -> if destr + then BT z left right -- removing the old value of a + else tree -- retaining the old value if one exists + +updateTreeEq :: + (Ord a) => (a -> a -> Bool) -> (a,b) -> BinTree (a,b) -> BinTree (a,b) +updateTreeEq eq z@(x,y) tree = case tree of + NT -> BT z NT NT + BT c@(a,b) left right + | eq x a -> BT (a,y) left right -- removing the old value of a + | x < a -> let left' = updateTree z left in BT c left' right + | x > a -> let right' = updateTree z right in BT c left right' + +updatesTree :: (Ord a) => [(a,b)] -> BinTree (a,b) -> BinTree (a,b) +updatesTree (z:zs) tr = updateTree z t where t = updatesTree zs tr +updatesTree [] tr = tr + +updatesTreeNondestr :: (Ord a) => [(a,b)] -> BinTree (a,b) -> BinTree (a,b) +updatesTreeNondestr xs tr = case xs of + (z:zs) -> updateTreeGen False z t where t = updatesTreeNondestr zs tr + _ -> tr + +buildTree :: (Ord a) => [(a,b)] -> BinTree (a,b) +buildTree = sorted2tree . sortBy fs where + fs (x,_) (y,_) + | x < y = LT + | x > y = GT + | True = EQ +-- buildTree zz = updatesTree zz NT + +sorted2tree :: [(a,b)] -> BinTree (a,b) +sorted2tree [] = NT +sorted2tree xs = BT x (sorted2tree t1) (sorted2tree t2) where + (t1,(x:t2)) = splitAt (length xs `div` 2) xs + +mapTree :: (a -> b) -> BinTree a -> BinTree b +mapTree f NT = NT +mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right) + +mapMTree :: Monad m => (a -> m b) -> BinTree a -> m (BinTree b) +mapMTree f NT = return NT +mapMTree f (BT a left right) = do + a' <- f a + left' <- mapMTree f left + right' <- mapMTree f right + return $ BT a' left' right' + +tree2list :: BinTree a -> [a] -- inorder +tree2list NT = [] +tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right + +depthTree :: BinTree a -> Int +depthTree NT = 0 +depthTree (BT _ left right) = 1 + max (depthTree left) (depthTree right) + +mergeTrees :: Ord a => BinTree (a,b) -> BinTree (a,b) -> BinTree (a,[b]) +mergeTrees old new = foldr upd new' (tree2list old) where + upd xy@(x,y) tree = case tree of + NT -> BT (x,[y]) NT NT + BT (a,bs) left right + | x < a -> let left' = upd xy left in BT (a,bs) left' right + | x > a -> let right' = upd xy right in BT (a,bs) left right' + | otherwise -> BT (a, y:bs) left right -- adding the new value + new' = mapTree (\ (i,d) -> (i,[d])) new + + +-- parsing + +type WParser a b = [a] -> [(b,[a])] -- old Wadler style parser + +wParseResults :: WParser a b -> [a] -> [b] +wParseResults p aa = [b | (b,[]) <- p aa] + +-- printing + +indent :: Int -> String -> String +indent i s = replicate i ' ' ++ s + +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 n s = concat (replicate n s) + +prTList t ss = case ss of + [] -> "" + [s] -> s + s:ss -> s ++ t ++ prTList t ss + +prQuotedString x = "\"" ++ restoreEscapes x ++ "\"" + +prParenth s = if s == "" then "" else "(" ++ s ++ ")" + +prCurly s = "{" ++ s ++ "}" +prBracket s = "[" ++ s ++ "]" + +prArgList xx = prParenth (prTList "," xx) + +prSemicList = prTList " ; " + +prCurlyList = prCurly . prSemicList + +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 +--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id +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!! + +-- LaTeX code producing functions + +dollar s = '$' : s ++ "$" +mbox s = "\\mbox{" ++ s ++ "}" +ital s = "{\\em" +++ s ++ "}" +boldf s = "{\\bf" +++ s ++ "}" +verbat s = "\\verbat!" ++ s ++ "!" + +mkLatexFile s = begindocument +++++ s +++++ enddocument + +begindocument = + "\\documentclass[a4paper,11pt]{article}" ++++ -- M.F. 25/01-02 + "\\setlength{\\parskip}{2mm}" ++++ + "\\setlength{\\parindent}{0mm}" ++++ + "\\setlength{\\oddsidemargin}{0mm}" ++++ + "\\setlength{\\evensidemargin}{-2mm}" ++++ + "\\setlength{\\topmargin}{-8mm}" ++++ + "\\setlength{\\textheight}{240mm}" ++++ + "\\setlength{\\textwidth}{158mm}" ++++ + "\\begin{document}\n" + +enddocument = + "\n\\end{document}\n" + +sortByLongest :: [[a]] -> [[a]] +sortByLongest = sortBy longer where + longer x y + | x' > y' = LT + | x' < y' = GT + | True = EQ + where + x' = length x + y' = length y + +combinations :: [[a]] -> [[a]] +combinations t = case t of + [] -> [[]] + aa:uu -> [a:u | a <- aa, u <- combinations uu] + +mkTextFile :: String -> IO () +mkTextFile name = do + s <- readFile name + let s' = prelude name ++ "\n\n" ++ heading name ++ "\n" ++ object s + writeFile (name ++ ".hs") s' + where + prelude name = "module " ++ name ++ " where" + heading name = "txt" ++ name ++ " =" + object s = mk s ++ " \"\"" + mk s = unlines [" \"" ++ escs line ++ "\" ++ \"\\n\" ++" | line <- lines s] + escs s = case s of + c:cs | elem c "\"\\" -> '\\' : c : escs cs + c:cs -> c : escs cs + _ -> s + +initFilePath :: FilePath -> FilePath +initFilePath f = reverse (dropWhile (/='/') (reverse f)) + +-- topological sorting with test of cyclicity + +topoTest :: Eq a => [(a,[a])] -> Either [a] [[a]] +topoTest g = if length g' == length g then Left g' else Right (cyclesIn g ++[[]]) + where + g' = topoSort g + +cyclesIn :: Eq a => [(a,[a])] -> [[a]] +cyclesIn deps = nubb $ clean $ filt $ iterFix findDep immediate where + immediate = [[y,x] | (x,xs) <- deps, y <- xs] + findDep chains = [y:x:chain | + x:chain <- chains, (x',xs) <- deps, x' == x, y <- xs, + notElem y (init chain)] + + clean = map remdup + nubb = nubBy (\x y -> y == reverse x) + filt = filter (\xs -> last xs == head xs) + remdup (x:xs) = x : remdup xs' where xs' = dropWhile (==x) xs + remdup [] = [] + + + +topoSort :: Eq a => [(a,[a])] -> [a] +topoSort g = reverse $ tsort 0 [ffs | ffs@(f,_) <- g, inDeg f == 0] [] where + tsort _ [] r = r + tsort k (ffs@(f,fs) : cs) r + | elem f r = tsort k cs r + | k > lx = r + | otherwise = tsort (k+1) cs (f : tsort (k+1) (info fs) r) + info hs = [(f,fs) | (f,fs) <- g, elem f hs] + inDeg f = length [t | (h,hs) <- g, t <- hs, t == f] + lx = length g + +-- the generic fix point iterator + +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) + +-- association lists + +updateAssoc :: Eq a => (a,b) -> [(a,b)] -> [(a,b)] +updateAssoc ab@(a,b) as = case as of + (x,y): xs | x == a -> (a,b):xs + xy : xs -> xy : updateAssoc ab xs + [] -> [ab] + +removeAssoc :: Eq a => a -> [(a,b)] -> [(a,b)] +removeAssoc a = filter ((/=a) . fst) + +-- chop into separator-separated parts + +chunks :: String -> [String] -> [[String]] +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 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)) + +done :: Monad m => m () +done = return () + +class 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 + +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 [] + |