Founding the newly structured GF2.0 cvs archive.

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 []
+