reorganize the directories under src, and rescue the JavaScript interpreter from deprecated

1 files changed, 374 insertions, 0 deletions

diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs
new file mode 100644
index 000000000..7b2afc9fe
--- /dev/null
+++ b/src/compiler/GF/Data/Operations.hs
@@ -0,0 +1,374 @@
+----------------------------------------------------------------------
+-- |
+-- 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, 
+		   lookupErr,
+		   mapPairListM, mapPairsM, pairM,
+		   singleton, mapsErr, mapsErrTree,
+		   
+		   -- ** checking
+		   checkUnique,
+
+		   -- * binary search trees; now with FiniteMap
+		   BinTree, emptyBinTree, isInBinTree, justLookupTree,
+		   lookupTree, lookupTreeMany, lookupTreeManyAll, updateTree,
+		   buildTree, filterBinTree,
+		   sorted2tree, mapTree, mapMTree, tree2list,
+ 
+
+		   -- * printing
+		   indent, (+++), (++-), (++++), (+++++),
+		   prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, 
+		   prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
+		   numberedParagraphs, prConjList, prIfEmpty, wrapLines,
+
+		   -- * extra
+		   combinations,
+
+		   -- * topological sorting with test of cyclicity
+		   topoTest, 
+
+		   -- * the generic fix point iterator
+		   iterFix,
+
+		   -- * chop into separator-separated parts
+		   chunks, readIntArg, 
+
+		   -- * 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 qualified Data.Map as Map
+import Data.Map (Map)
+import Control.Monad (liftM,liftM2, MonadPlus, mzero, mplus)
+
+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
+
+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
+
+lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err 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 a => (b -> a c) -> (b,b) -> a (c,c)
+pairM op (t1,t2) = liftM2 (,) (op t1) (op t2)
+
+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
+
+-- 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 :: (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 Map.lookup x tree 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 = []
+
+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
+
+sorted2tree :: Ord a => [(a,b)] -> BinTree a b
+sorted2tree = Map.fromAscList
+
+mapTree :: ((a,b) -> c) -> BinTree a b -> BinTree a c
+mapTree f = Map.mapWithKey (\k v -> f (k,v))
+
+mapMTree :: (Ord a,Monad m) => ((a,b) -> m c) -> BinTree a b -> m (BinTree a c)
+mapMTree f t = liftM Map.fromList $ sequence [liftM ((,) k) (f (k,x)) | (k,x) <- Map.toList t]
+
+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]
+
+-- | topological sorting with test of cyclicity
+topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
+topoTest = topologicalSort . mkRel'
+
+-- | 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)
+
+-- | 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))
+
+-- error recovery with multiple reporting AR 30/5/2008
+mapsErr :: (a -> Err b) -> [a] -> Err [b]
+
+mapsErr f = seqs . map f where
+  seqs es = case es of
+    Ok v : ms -> case seqs ms of
+      Ok vs -> return (v : vs)
+      b     -> b
+    Bad s : ms -> case seqs ms of
+      Ok vs  -> Bad s
+      Bad ss -> Bad (s +++++ ss)
+    [] -> return []
+
+mapsErrTree :: (Ord a) => ((a,b) -> Err (a,c)) -> BinTree a b -> Err (BinTree a c)
+mapsErrTree f t =  mapsErr f (tree2list t) >>= return . sorted2tree
+
+
+-- | 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"