diff options
Diffstat (limited to 'src/GF/Data/Operations.hs')
| -rw-r--r-- | src/GF/Data/Operations.hs | 658 |
1 files changed, 0 insertions, 658 deletions
diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs deleted file mode 100644 index 1b2033d69..000000000 --- a/src/GF/Data/Operations.hs +++ /dev/null @@ -1,658 +0,0 @@ ----------------------------------------------------------------------- --- | --- 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 (-- * misc functions - ifNull, onSnd, - - -- * the Error monad - Err(..), err, maybeErr, testErr, errVal, errIn, derrIn, - performOps, repeatUntilErr, repeatUntil, okError, isNotError, - showBad, lookupErr, lookupErrMsg, lookupDefault, updateLookupList, - mapPairListM, mapPairsM, pairM, mapErr, mapErrN, foldErr, - (!?), errList, singleton, - - -- ** checking - checkUnique, titleIfNeeded, errMsg, errAndMsg, - - -- * a three-valued maybe type to express indirections - Perhaps(..), yes, may, nope, - mapP, - unifPerhaps, updatePerhaps, updatePerhapsHard, - - -- * binary search trees; now with FiniteMap - BinTree, emptyBinTree, isInBinTree, justLookupTree, - lookupTree, lookupTreeMany, lookupTreeManyAll, updateTree, - buildTree, filterBinTree, - sorted2tree, mapTree, mapMTree, tree2list, - - - -- * parsing - WParser, wParseResults, paragraphs, - - -- * printing - indent, (+++), (++-), (++++), (+++++), - prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, - prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes, - numberedParagraphs, prConjList, prIfEmpty, wrapLines, - - -- ** LaTeX code producing functions - dollar, mbox, ital, boldf, verbat, mkLatexFile, - begindocument, enddocument, - - -- * extra - sortByLongest, combinations, mkTextFile, initFilePath, - - -- * topological sorting with test of cyclicity - topoTest, topoSort, cyclesIn, - - -- * the generic fix point iterator - iterFix, - - -- * association lists - updateAssoc, removeAssoc, - - -- * chop into separator-separated parts - chunks, readIntArg, subSequences, - - -- * state monad with error; from Agda 6\/11\/2001 - STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM, done, - - -- * error monad class - ErrorMonad(..), checkAgain, checks, allChecks, doUntil - - ) where - -import Data.Char (isSpace, toUpper, isSpace, isDigit) -import Data.List (nub, sortBy, sort, deleteBy, nubBy) ---import Data.FiniteMap -import Control.Monad (liftM,liftM2, MonadPlus, mzero, mplus) - -import GF.Data.ErrM - -infixr 5 +++ -infixr 5 ++- -infixr 5 ++++ -infixr 5 +++++ -infixl 9 !? - -ifNull :: b -> ([a] -> b) -> [a] -> b -ifNull b f xs = if null xs then b else f xs - -onSnd :: (a -> b) -> (c,a) -> (c,b) -onSnd f (x, y) = (x, f y) - --- the Error monad - --- | 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 -okError = err (error . ("Bad result occurred" ++++)) 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 = 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 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 - --- | alternative variant, peb 9\/6-04 -mapErrN :: Int -> (a -> Err b) -> [a] -> Err ([b], String) -mapErrN maxN f xs = Ok (ys, unlines (errHdr : ss2)) - where - (ys, ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs]) - errHdr = show nss ++ " errors occured" ++ - if nss > maxN then ", showing the first " ++ show maxN else "" - ss2 = map ("* "++) $ take maxN ss - nss = length ss - fxs = map f xs - --- | like @foldM@, but also return the latest value if fails -foldErr :: (a -> b -> Err a) -> a -> [b] -> Err (a, Maybe String) -foldErr f s xs = case xs of - [] -> return (s,Nothing) - x:xx -> case f s x of - Ok v -> foldErr f v xx - Bad m -> return $ (s, Just m) - --- @!!@ 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 :: a -> Perhaps a b -yes = Yes - -may :: b -> Perhaps a b -may = May - -nope :: Perhaps a b -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 :: (Eq a, Eq b, Show a, Show b) => - Perhaps a b -> Perhaps a b -> Err (Perhaps a b) -unifPerhaps p1 p2 = case (p1,p2) of - (Nope, _) -> return p2 - (_, Nope) -> return p1 - _ -> if p1==p2 then return p1 - else Bad ("update conflict between" ++++ show p1 ++++ show p2) - --- | this is what happens when updating a module extension -updatePerhaps :: (Eq a,Eq b, Show a, Show b) => - 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 - --- | here the value is copied instead of referred to; used for oper types -updatePerhapsHard :: (Eq a, Eq b, Show a, Show b) => b -> - Perhaps a b -> Perhaps a b -> Err (Perhaps a b) -updatePerhapsHard old p1 p2 = case (p1,p2) of - (Yes a, Nope) -> return $ yes a - (May older,Nope) -> return $ may older - (_, May a) -> Bad "strange indirection" - _ -> unifPerhaps p1 p2 - --- binary search trees ---- FiniteMap implementation is slower in crucial tests - -data BinTree a b = NT | BT (a,b) !(BinTree a b) !(BinTree a b) deriving (Show) --- type BinTree a b = FiniteMap a b - -emptyBinTree :: BinTree a b -emptyBinTree = NT --- emptyBinTree = emptyFM - -isInBinTree :: (Ord a) => a -> BinTree a b -> Bool -isInBinTree x = err (const False) (const True) . justLookupTree x --- isInBinTree = elemFM - -justLookupTree :: (Monad m,Ord a) => a -> BinTree a b -> m b -justLookupTree = lookupTree (const []) - -lookupTree :: (Monad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b -lookupTree pr x tree = case tree of - NT -> fail ("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 ---lookupTree pr x tree = case lookupFM tree x of --- Just y -> return y --- _ -> fail ("no occurrence of element" +++ pr x) - -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 - -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 = [] - --- | destructive update -updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b --- updateTree (a,b) tr = addToFM tr 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 - -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 = listToFM - -sorted2tree :: Ord a => [(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 ---sorted2tree = listToFM - ---- dm less general than orig -mapTree :: ((a,b) -> (a,c)) -> BinTree a b -> BinTree a c -mapTree f NT = NT -mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right) ---mapTree f = mapFM (\k v -> snd (f (k,v))) - ---- fm less efficient than orig? -mapMTree :: (Ord a,Monad m) => ((a,b) -> m (a,c)) -> BinTree a b -> m (BinTree a c) -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' ---mapMTree f t = liftM listToFM $ mapM f $ fmToList t - -filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b --- filterFM f t -filterBinTree f = sorted2tree . filter (uncurry f) . tree2list - -tree2list :: BinTree a b -> [(a,b)] -- inorder -tree2list NT = [] -tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right ---tree2list = fmToList - --- 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] - -paragraphs :: String -> [String] -paragraphs = map unlines . chop . lines where - chop [] = [] - chop ss = let (ps,rest) = break empty ss in ps : chop (dropWhile empty rest) - empty = all isSpace - --- 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 - --- LaTeX code producing functions -dollar, mbox, ital, boldf, verbat :: String -> String -dollar s = '$' : s ++ "$" -mbox s = "\\mbox{" ++ s ++ "}" -ital s = "{\\em" +++ s ++ "}" -boldf s = "{\\bf" +++ s ++ "}" -verbat s = "\\verbat!" ++ s ++ "!" - -mkLatexFile :: String -> String -mkLatexFile s = begindocument +++++ s +++++ enddocument - -begindocument, enddocument :: String -begindocument = - "\\documentclass[a4paper,11pt]{article}" ++++ -- M.F. 25/01-02 - "\\setlength{\\parskip}{2mm}" ++++ - "\\setlength{\\parindent}{0mm}" ++++ - "\\setlength{\\oddsidemargin}{0mm}" ++++ - ("\\setlength{\\evensidemargin}{"++"-2mm}") ++++ -- peb 27/5-04: to prevent hugs-mode - ("\\setlength{\\topmargin}{"++"-8mm}") ++++ -- from treating the rest as comments - "\\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' 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] - - -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 [] = [] - - --- | topological sorting -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 :: 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 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 [] - -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" - --- subsequences sorted from longest to shortest ; their number is 2^n -subSequences :: [a] -> [[a]] -subSequences = sortBy (\x y -> compare (length y) (length x)) . subs where - subs xs = case xs of - [] -> [[]] - x:xs -> let xss = subs xs in [x:y | y <- xss] ++ xss |