reintroduce the compiler API

2024-01-18 20:58:10 +01:00
parent 282c6fc50f
commit a82095d117
138 changed files with 84 additions and 342 deletions
--- a/src/compiler/api/GF/Data/BacktrackM.hs
+++ b/src/compiler/api/GF/Data/BacktrackM.hs
@@ -0,0 +1,103 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : BacktrackM
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:00 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.4 $
+--
+-- Backtracking state monad, with r\/o environment
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+module GF.Data.BacktrackM (
+                    -- * the backtracking state monad
+                    BacktrackM,
+                    -- * monad specific utilities
+                    member,
+                    cut,
+                    -- * running the monad
+                    foldBM,          runBM,
+                    foldSolutions,   solutions,
+                    foldFinalStates, finalStates,
+
+                    -- * reexport the 'MonadState' class
+                    module Control.Monad.State.Class,
+                  ) where
+
+import Data.List
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State.Class
+import qualified Control.Monad.Fail as Fail
+
+----------------------------------------------------------------------
+-- Combining endomorphisms and continuations
+-- a la Ralf Hinze
+
+-- BacktrackM = state monad transformer over the backtracking monad
+
+newtype BacktrackM s a = BM (forall b . (a -> s -> b -> b) -> s -> b -> b)
+
+-- * running the monad
+
+runBM :: BacktrackM s a -> s -> [(s,a)]
+runBM (BM m) s = m (\x s xs -> (s,x) : xs) s []
+
+foldBM :: (a -> s -> b -> b) -> b -> BacktrackM s a -> s -> b
+foldBM f b (BM m) s = m f s b
+
+foldSolutions   :: (a -> b -> b) -> b -> BacktrackM s a -> s -> b
+foldSolutions f b (BM m) s = m (\x s b -> f x b) s b
+
+solutions   :: BacktrackM s a  -> s -> [a]
+solutions = foldSolutions (:) []
+
+foldFinalStates :: (s -> b -> b) -> b -> BacktrackM s () -> s -> b
+foldFinalStates f b (BM m) s = m (\x s b -> f s b) s b
+
+finalStates :: BacktrackM s () -> s -> [s]
+finalStates bm = map fst . runBM bm
+
+instance Applicative (BacktrackM s) where
+    pure = return
+    (<*>) = ap
+
+instance Monad (BacktrackM s) where
+    return a   = BM (\c s b -> c a s b)
+    BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b)
+        where unBM (BM m) = m
+
+#if !(MIN_VERSION_base(4,13,0))
+    fail = Fail.fail
+#endif
+
+instance Fail.MonadFail (BacktrackM s) where
+    fail _ = mzero
+
+instance Functor (BacktrackM s) where
+    fmap f (BM m) = BM (\c s b -> m (\a s b -> c (f a) s b) s b)
+
+instance Alternative (BacktrackM s) where
+   empty = mzero
+   (<|>) = mplus
+
+instance MonadPlus (BacktrackM s) where
+    mzero                 = BM (\c s b -> b)
+    (BM f) `mplus` (BM g) = BM (\c s b -> g c s $! f c s b)
+
+instance MonadState s (BacktrackM s) where
+  get = BM (\c s b -> c s s b)
+  put s = BM (\c _ b -> c () s b)
+
+-- * specific functions on the backtracking monad
+
+member :: [a] -> BacktrackM s a
+member xs = BM (\c s b -> foldl' (\b x -> c x s b) b xs)
+
+cut :: BacktrackM s a -> BacktrackM s [(s,a)]
+cut f = BM (\c s b -> c (runBM f s) s b)
--- a/src/compiler/api/GF/Data/ErrM.hs
+++ b/src/compiler/api/GF/Data/ErrM.hs
@@ -0,0 +1,68 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ErrM
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:00 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.5 $
+--
+-- hack for BNFC generated files. AR 21/9/2003
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+module GF.Data.ErrM where
+
+import Control.Monad (MonadPlus(..),ap)
+import Control.Applicative
+import qualified Control.Monad.Fail as Fail
+
+-- | Like 'Maybe' type with error msgs
+data Err a = Ok a | Bad String
+  deriving (Read, Show, Eq)
+
+-- | 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
+
+-- | Analogue of 'fromMaybe'
+fromErr :: a -> Err a -> a
+fromErr a = err (const a) id
+
+instance Monad Err where
+  return      = Ok
+  Ok a  >>= f = f a
+  Bad s >>= f = Bad s
+
+#if !(MIN_VERSION_base(4,13,0))
+  -- Monad(fail) will be removed in GHC 8.8+
+  fail = Fail.fail
+#endif
+
+instance Fail.MonadFail Err where
+  fail        = Bad
+
+
+
+-- | added 2\/10\/2003 by PEB
+instance Functor Err where
+  fmap f (Ok a) = Ok (f a)
+  fmap f (Bad s) = Bad s
+
+instance Applicative Err where
+  pure = return
+  (<*>) = ap
+
+-- | added by KJ
+instance MonadPlus Err where
+    mzero = Bad "error (no reason given)"
+    mplus (Ok a)  _ = Ok a
+    mplus (Bad s) b = b
+
+instance Alternative Err where
+    empty = mzero
+    (<|>) = mplus
--- a/src/compiler/api/GF/Data/Graph.hs
+++ b/src/compiler/api/GF/Data/Graph.hs
@@ -0,0 +1,178 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Graph
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/10 16:43:44 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.2 $
+--
+-- A simple graph module.
+-----------------------------------------------------------------------------
+module GF.Data.Graph ( Graph(..), Node, Edge, NodeInfo
+                        , newGraph, nodes, edges
+                        , nmap, emap, newNode, newNodes, newEdge, newEdges
+                        , insertEdgeWith
+                        , removeNode, removeNodes
+                        , nodeInfo
+                        , getIncoming, getOutgoing, getNodeLabel
+                        , inDegree, outDegree
+                        , nodeLabel
+                        , edgeFrom, edgeTo, edgeLabel
+                        , reverseGraph, mergeGraphs, renameNodes
+                       ) where
+
+--import GF.Data.Utilities
+
+import Data.List
+import Data.Maybe
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
+    deriving (Eq,Show)
+
+type Node n a = (n,a)
+type Edge n b = (n,n,b)
+
+type NodeInfo n a b = Map n (a, [Edge n b], [Edge n b])
+
+-- | Create a new empty graph.
+newGraph :: [n] -> Graph n a b
+newGraph ns = Graph ns [] []
+
+-- | Get all the nodes in the graph.
+nodes :: Graph n a b -> [Node n a]
+nodes (Graph _ ns _) = ns
+
+-- | Get all the edges in the graph.
+edges :: Graph n a b -> [Edge n b]
+edges (Graph _ _ es) = es
+
+-- | Map a function over the node labels.
+nmap :: (a -> c) -> Graph n a b -> Graph n c b
+nmap f (Graph c ns es) = Graph c [(n,f l) | (n,l) <- ns] es
+
+-- | Map a function over the edge labels.
+emap :: (b -> c) -> Graph n a b -> Graph n a c
+emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
+
+-- | Add a node to the graph.
+newNode :: a               -- ^ Node label
+        -> Graph n a b
+        -> (Graph n a b,n) -- ^ Node graph and name of new node
+newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
+
+newNodes :: [a] -> Graph n a b -> (Graph n a b,[Node n a])
+newNodes ls g = (g', zip ns ls)
+  where (g',ns) = mapAccumL (flip newNode) g ls
+-- lazy version:
+--newNodes ls (Graph cs ns es) = (Graph cs' (ns'++ns) es, ns')
+--  where (xs,cs') = splitAt (length ls) cs
+--        ns' = zip xs ls
+
+newEdge :: Edge n b -> Graph n a b -> Graph n a b
+newEdge e (Graph c ns es) = Graph c ns (e:es)
+
+newEdges :: [Edge n b] -> Graph n a b -> Graph n a b
+newEdges es g = foldl' (flip newEdge) g es
+-- lazy version:
+-- newEdges es' (Graph c ns es) = Graph c ns (es'++es)
+
+insertEdgeWith :: Eq n =>
+                  (b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b
+insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es)
+  where h [] = [e]
+        h (e'@(x',y',l'):es') | x' == x && y' == y = (x',y', f l l'):es'
+                              | otherwise = e':h es'
+
+-- | Remove a node and all edges to and from that node.
+removeNode :: Ord n => n -> Graph n a b -> Graph n a b
+removeNode n = removeNodes (Set.singleton n)
+
+-- | Remove a set of nodes and all edges to and from those nodes.
+removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b
+removeNodes xs (Graph c ns es) = Graph c ns' es'
+  where
+  keepNode n = not (Set.member n xs)
+  ns' = [ x | x@(n,_) <- ns, keepNode n ]
+  es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ]
+
+-- | Get a map of node names to info about each node.
+nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b
+nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ]
+  where
+  inc = groupEdgesBy edgeTo g
+  out = groupEdgesBy edgeFrom g
+  fn m n = fromMaybe [] (Map.lookup n m)
+
+groupEdgesBy :: (Ord n) => (Edge n b -> n) -- ^ Gets the node to group by
+             -> Graph n a b -> Map n [Edge n b]
+groupEdgesBy f g = Map.fromListWith (++) [(f e, [e]) | e <- edges g]
+
+lookupNode :: Ord n => NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b])
+lookupNode i n = fromJust $ Map.lookup n i
+
+getIncoming :: Ord n => NodeInfo n a b -> n -> [Edge n b]
+getIncoming i n = let (_,inc,_) = lookupNode i n in inc
+
+getOutgoing :: Ord n => NodeInfo n a b -> n -> [Edge n b]
+getOutgoing i n = let (_,_,out) = lookupNode i n in out
+
+inDegree :: Ord n => NodeInfo n a b -> n -> Int
+inDegree i n = length $ getIncoming i n
+
+outDegree :: Ord n => NodeInfo n a b -> n -> Int
+outDegree i n = length $ getOutgoing i n
+
+getNodeLabel :: Ord n => NodeInfo n a b -> n -> a
+getNodeLabel i n = let (l,_,_) = lookupNode i n in l
+
+nodeLabel :: Node n a -> a
+nodeLabel = snd
+
+edgeFrom :: Edge n b -> n
+edgeFrom (f,_,_) = f
+
+edgeTo :: Edge n b -> n
+edgeTo (_,t,_) = t
+
+edgeLabel :: Edge n b -> b
+edgeLabel (_,_,l) = l
+
+reverseGraph :: Graph n a b -> Graph n a b
+reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
+
+-- | Add the nodes from the second graph to the first graph.
+--   The nodes in the second graph will be renamed using the name
+--   supply in the first graph.
+--   This function is more efficient when the second graph
+--   is smaller than the first.
+mergeGraphs :: Ord m => Graph n a b -> Graph m a b
+            -> (Graph n a b, m -> n) -- ^ The new graph and a function translating
+                                      --  the old names of nodes in the second graph
+                                      --  to names in the new graph.
+mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName)
+  where
+  (xs,c') = splitAt (length (nodes g2)) c
+  newNames = Map.fromList (zip (map fst (nodes g2)) xs)
+  newName n = fromJust $ Map.lookup n newNames
+  Graph _ ns2 es2 = renameNodes newName undefined g2
+
+-- | Rename the nodes in the graph.
+renameNodes :: (n -> m) -- ^ renaming function
+            -> [m] -- ^ infinite supply of fresh node names, to
+                   --   use when adding nodes in the future.
+            -> Graph n a b -> Graph m a b
+renameNodes newName c (Graph _ ns es) = Graph c ns' es'
+    where ns' = map' (\ (n,x) -> (newName n,x)) ns
+          es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
+
+-- | A strict 'map'
+map' :: (a -> b) -> [a] -> [b]
+map' _ [] = []
+map' f (x:xs) = ((:) $! f x) $! map' f xs
--- a/src/compiler/api/GF/Data/Graphviz.hs
+++ b/src/compiler/api/GF/Data/Graphviz.hs
@@ -0,0 +1,116 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Graphviz
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/15 18:10:44 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.2 $
+--
+-- Graphviz DOT format representation and printing.
+-----------------------------------------------------------------------------
+
+module GF.Data.Graphviz (
+                          Graph(..), GraphType(..),
+                          Node(..), Edge(..),
+                          Attr,
+                          addSubGraphs,
+                          setName,
+                          setAttr,
+                          prGraphviz
+                        ) where
+
+import Data.Char
+
+import GF.Data.Utilities
+
+-- | Graph type, graph ID, graph attirbutes, graph nodes, graph edges, subgraphs
+data Graph = Graph {
+                    gType :: GraphType,
+                    gId :: Maybe String,
+                    gAttrs :: [Attr],
+                    gNodes :: [Node],
+                    gEdges :: [Edge],
+                    gSubgraphs :: [Graph]
+                   }
+  deriving (Show)
+
+data GraphType = Directed | Undirected
+  deriving (Show)
+
+data Node = Node String [Attr]
+  deriving Show
+
+data Edge = Edge String String [Attr]
+  deriving Show
+
+type Attr = (String,String)
+
+--
+-- * Graph construction
+--
+
+addSubGraphs :: [Graph] -> Graph -> Graph
+addSubGraphs gs g = g { gSubgraphs = gs ++ gSubgraphs g }
+
+setName :: String -> Graph -> Graph
+setName n g = g { gId = Just n }
+
+setAttr :: String -> String -> Graph -> Graph
+setAttr n v g = g { gAttrs = tableSet n v (gAttrs g) }
+
+--
+-- * Pretty-printing
+--
+
+prGraphviz :: Graph -> String
+prGraphviz g@(Graph t i _ _ _ _) =
+    graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n"
+
+prSubGraph :: Graph -> String
+prSubGraph g@(Graph _ i _ _ _ _) =
+    "subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}"
+
+prGraph :: Graph -> String
+prGraph (Graph t id at ns es ss) =
+    unlines $ map (++";") (map prAttr at
+                           ++ map prNode ns
+                           ++ map (prEdge t) es
+                           ++ map prSubGraph ss)
+
+graphtype :: GraphType -> String
+graphtype Directed = "digraph"
+graphtype Undirected = "graph"
+
+prNode :: Node -> String
+prNode (Node n at) = esc n ++ " " ++ prAttrList at
+
+prEdge :: GraphType -> Edge -> String
+prEdge t (Edge x y at) = esc x ++ " " ++ edgeop t ++ " " ++ esc y ++ " " ++ prAttrList at
+
+edgeop :: GraphType -> String
+edgeop Directed = "->"
+edgeop Undirected = "--"
+
+prAttrList :: [Attr] -> String
+prAttrList [] = ""
+prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"
+
+prAttr :: Attr -> String
+prAttr (n,v) = esc n ++ " = " ++ esc v
+
+esc :: String -> String
+esc s | needEsc s = "\"" ++ concat [ if shouldEsc c then ['\\',c] else [c] | c <- s ] ++ "\""
+      | otherwise = s
+  where shouldEsc = (`elem` ['"', '\\'])
+
+needEsc :: String -> Bool
+needEsc [] = True
+needEsc xs | all isDigit xs = False
+needEsc (x:xs) = not (isIDFirst x && all isIDChar xs)
+
+isIDFirst, isIDChar :: Char -> Bool
+isIDFirst c = c `elem` (['_']++['a'..'z']++['A'..'Z'])
+isIDChar c = isIDFirst c || isDigit c
--- a/src/compiler/api/GF/Data/Operations.hs
+++ b/src/compiler/api/GF/Data/Operations.hs
@@ -0,0 +1,269 @@
+----------------------------------------------------------------------
+-- |
+-- 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 (
+     -- ** The Error monad
+     Err(..), err, maybeErr, testErr, fromErr, errIn,
+     lookupErr,
+
+     -- ** Error monad class
+     ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
+                 liftErr,
+
+     -- ** Checking
+     checkUnique, unifyMaybeBy, unifyMaybe,
+
+         -- ** Monadic operations on lists and pairs
+     mapPairsM, pairM,
+
+     -- ** Printing
+     indent, (+++), (++-), (++++), (+++-), (+++++),
+     prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
+     prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
+     numberedParagraphs, prConjList, prIfEmpty, wrapLines,
+
+     -- ** Topological sorting
+     topoTest, topoTest2,
+
+     -- ** Misc
+     readIntArg,
+     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.Applicative(Applicative(..))
+import Control.Monad (liftM,liftM2) --,ap
+
+import GF.Data.ErrM
+import GF.Data.Relation
+import qualified Control.Monad.Fail as Fail
+
+infixr 5 +++
+infixr 5 ++-
+infixr 5 ++++
+infixr 5 +++++
+
+-- the Error monad
+
+-- | Add msg s to 'Maybe' failures
+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 return () 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)
+
+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)
+
+-- 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
+
+-- | this is what happens when matching two values in the same module
+unifyMaybe :: (Eq a, Fail.MonadFail m) => Maybe a -> Maybe a -> m (Maybe a)
+unifyMaybe = unifyMaybeBy id
+
+unifyMaybeBy :: (Eq b, Fail.MonadFail 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
+
+-- 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 +++- "" = 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
+
+-- | 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!!
+
+-- | Topological sorting with test of cyclicity
+topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
+topoTest = topologicalSort . mkRel'
+
+-- | Topological sorting with test of cyclicity, new version /TH 2012-06-26
+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
+
+
+-- | Fix point iterator (for computing e.g. transitive closures or reachability)
+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
+
+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
+{-
+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"
+-}
--- a/src/compiler/api/GF/Data/Relation.hs
+++ b/src/compiler/api/GF/Data/Relation.hs
@@ -0,0 +1,193 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Relation
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/26 17:13:13 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- A simple module for relations.
+-----------------------------------------------------------------------------
+
+module GF.Data.Relation (Rel, mkRel, mkRel'
+                           , allRelated , isRelatedTo
+                           , transitiveClosure
+                           , reflexiveClosure, reflexiveClosure_
+                           , symmetricClosure
+                           , symmetricSubrelation, reflexiveSubrelation
+                           , reflexiveElements
+                           , equivalenceClasses
+                           , isTransitive, isReflexive, isSymmetric
+                           , isEquivalence
+                           , isSubRelationOf
+                           , topologicalSort, findCycles) where
+
+import Data.Foldable (toList)
+--import Data.List
+import Data.Maybe
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import GF.Data.Utilities
+
+type Rel a = Map a (Set a)
+
+-- | Creates a relation from a list of related pairs.
+mkRel :: Ord a => [(a,a)] -> Rel a
+mkRel ps = relates ps Map.empty
+
+-- | Creates a relation from a list pairs of elements and the elements
+--   related to them.
+mkRel' :: Ord a => [(a,[a])] -> Rel a
+mkRel' xs = Map.fromListWith Set.union [(x,Set.fromList ys) | (x,ys) <- xs]
+
+relToList :: Ord a => Rel a -> [(a,a)]
+relToList r = [ (x,y) | (x,ys) <- Map.toList r, y <- Set.toList ys ]
+
+-- | Add a pair to the relation.
+relate :: Ord a => a -> a -> Rel a -> Rel a
+relate x y r = Map.insertWith Set.union x (Set.singleton y) r
+
+-- | Add a list of pairs to the relation.
+relates :: Ord a => [(a,a)] -> Rel a -> Rel a
+relates ps r = foldl (\r' (x,y) -> relate x y r') r ps
+
+-- | Checks if an element is related to another.
+isRelatedTo :: Ord a => Rel a -> a  -> a -> Bool
+isRelatedTo r x y = maybe False (y `Set.member`) (Map.lookup x r)
+
+-- | Get the set of elements to which a given element is related.
+allRelated :: Ord a => Rel a -> a -> Set a
+allRelated r x = fromMaybe Set.empty (Map.lookup x r)
+
+-- | Get all elements in the relation.
+domain :: Ord a => Rel a -> Set a
+domain r = foldl Set.union (Map.keysSet r) (Map.elems r)
+
+reverseRel :: Ord a => Rel a -> Rel a
+reverseRel r = mkRel [(y,x) | (x,y) <- relToList r]
+
+-- | Keep only pairs for which both elements are in the given set.
+intersectSetRel :: Ord a => Set a -> Rel a -> Rel a
+intersectSetRel s = filterRel (\x y -> x `Set.member` s && y `Set.member` s)
+
+transitiveClosure :: Ord a => Rel a -> Rel a
+transitiveClosure r = fix (Map.map growSet) r
+  where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)
+
+reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
+                  -> Rel a -> Rel a
+reflexiveClosure_ u r = relates [(x,x) | x <- u] r
+
+-- | Uses 'domain'
+reflexiveClosure :: Ord a => Rel a -> Rel a
+reflexiveClosure r = reflexiveClosure_ (Set.toList $ domain r) r
+
+symmetricClosure :: Ord a => Rel a -> Rel a
+symmetricClosure r = relates [ (y,x) | (x,y) <- relToList r ] r
+
+symmetricSubrelation :: Ord a => Rel a -> Rel a
+symmetricSubrelation r = filterRel (flip $ isRelatedTo r) r
+
+reflexiveSubrelation :: Ord a => Rel a -> Rel a
+reflexiveSubrelation r = intersectSetRel (reflexiveElements r) r
+
+-- | Get the set of elements which are related to themselves.
+reflexiveElements :: Ord a => Rel a -> Set a
+reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
+
+-- | Keep the related pairs for which the predicate is true.
+filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
+filterRel p = fst . purgeEmpty . Map.mapWithKey (Set.filter . p)
+
+-- | Remove keys that map to no elements.
+purgeEmpty :: Ord a => Rel a -> (Rel a, Set a)
+purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r
+                in (r', Map.keysSet r'')
+
+-- | Get the equivalence classes from an equivalence relation.
+equivalenceClasses :: Ord a => Rel a -> [Set a]
+equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
+ where equivalenceClasses_ [] _ = []
+       equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
+          where ys = allRelated r x
+                zs = [x' | x' <- xs, not (x' `Set.member` ys)]
+
+isTransitive :: Ord a => Rel a -> Bool
+isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
+                      y <- Set.toList ys, z <- Set.toList (allRelated r y)]
+
+isReflexive :: Ord a => Rel a -> Bool
+isReflexive r = all (\ (x,ys) -> x `Set.member` ys) (Map.toList r)
+
+isSymmetric :: Ord a => Rel a -> Bool
+isSymmetric r = and [isRelatedTo r y x | (x,y) <- relToList r]
+
+isEquivalence :: Ord a => Rel a -> Bool
+isEquivalence r = isReflexive r && isSymmetric r && isTransitive r
+
+isSubRelationOf :: Ord a => Rel a -> Rel a -> Bool
+isSubRelationOf r1 r2 = all (uncurry (isRelatedTo r2)) (relToList r1)
+
+-- | Returns 'Left' if there are cycles, and 'Right' if there are cycles.
+topologicalSort :: Ord a => Rel a -> Either [a] [[a]]
+topologicalSort r = tsort r' noIncoming Seq.empty
+  where r' = relToRel' r
+        noIncoming = Seq.fromList [x | (x,(is,_)) <- Map.toList r', Set.null is]
+
+tsort :: Ord a => Rel' a -> Seq a -> Seq a -> Either [a] [[a]]
+tsort r xs l = case Seq.viewl xs of
+                 Seq.EmptyL | isEmpty' r -> Left (toList l)
+                            | otherwise  -> Right (findCycles (rel'ToRel r))
+                 x Seq.:< xs -> tsort r' (xs Seq.>< Seq.fromList new) (l Seq.|> x)
+                     where (r',_,os) = remove x r
+                           new = [o | o <- Set.toList os, Set.null (incoming o r')]
+
+findCycles :: Ord a => Rel a -> [[a]]
+findCycles = map Set.toList . equivalenceClasses . reflexiveSubrelation . symmetricSubrelation . transitiveClosure
+
+--
+-- * Alternative representation that keeps both incoming and outgoing edges
+--
+
+-- | Keeps both incoming and outgoing edges.
+type Rel' a = Map a (Set a, Set a)
+
+isEmpty' :: Ord a => Rel' a -> Bool
+isEmpty' = Map.null
+
+relToRel' :: Ord a => Rel a -> Rel' a
+relToRel' r = Map.unionWith (\ (i,_) (_,o) -> (i,o)) ir or
+  where ir = Map.map (\s -> (s,Set.empty)) $ reverseRel r
+        or = Map.map (\s -> (Set.empty,s)) $ r
+
+rel'ToRel :: Ord a => Rel' a -> Rel a
+rel'ToRel = Map.map snd
+
+-- | Removes an element from a relation.
+-- Returns the new relation, and the set of incoming and outgoing edges
+-- of the removed element.
+remove :: Ord a => a -> Rel' a -> (Rel' a, Set a, Set a)
+remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r
+              in case mss of
+                   -- element was not in the relation
+                   Nothing      -> (r', Set.empty, Set.empty)
+                   -- remove element from all incoming and outgoing sets
+                   -- of other elements
+                   Just (is,os) ->
+                       let r''  = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r'  $ Set.toList is
+                           r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os
+                        in (r''', is, os)
+
+incoming :: Ord a => a -> Rel' a -> Set a
+incoming x r = maybe Set.empty fst $ Map.lookup x r
+
+--outgoing :: Ord a => a -> Rel' a -> Set a
+--outgoing x r = maybe Set.empty snd $ Map.lookup x r
--- a/src/compiler/api/GF/Data/SortedList.hs
+++ b/src/compiler/api/GF/Data/SortedList.hs
@@ -0,0 +1,127 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : Peter Ljunglöf
+-- Stability   : stable
+-- Portability : portable
+--
+-- > CVS $Date: 2005/04/21 16:22:08 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.3 $
+--
+-- Sets as sorted lists
+--
+--    * /O(n)/   union, difference and intersection 
+--
+--    * /O(n log n)/ creating a set from a list (=sorting)
+--
+--    * /O(n^2)/ fixed point iteration
+-----------------------------------------------------------------------------
+
+module GF.Data.SortedList
+    ( -- * type declarations
+      SList, SMap,
+      -- * set operations		    
+      nubsort, union, 
+      (<++>), (<\\>), (<**>), 
+      limit,
+      hasCommonElements, subset, 
+      -- * map operations
+      groupPairs, groupUnion,
+      unionMap, mergeMap
+    ) where
+
+import Data.List (groupBy)
+import GF.Data.Utilities (split, foldMerge)
+
+-- | The list must be sorted and contain no duplicates.
+type SList a = [a]
+
+-- | A sorted map also has unique keys, 
+-- i.e. 'map fst m :: SList a', if 'm :: SMap a b'
+type SMap a b = SList (a, b)
+
+-- | Group a set of key-value pairs into a sorted map
+groupPairs :: Ord a => SList (a, b) -> SMap a (SList b)
+groupPairs = map mapFst . groupBy eqFst
+    where mapFst as = (fst (head as), map snd as)
+	  eqFst a b = fst a == fst b
+
+-- | Group a set of key-(sets-of-values) pairs into a sorted map
+groupUnion :: (Ord a, Ord b) => SList (a, SList b) -> SMap a (SList b)
+groupUnion = map unionSnd . groupPairs
+    where unionSnd (a, bs) = (a, union bs)
+
+-- | True is the two sets has common elements
+hasCommonElements :: Ord a => SList a -> SList a -> Bool
+hasCommonElements as bs = not (null (as <**> bs))
+
+-- | True if the first argument is a subset of the second argument
+subset :: Ord a => SList a -> SList a -> Bool
+xs `subset` ys = null (xs <\\> ys)
+
+-- | Create a set from any list.
+-- This function can also be used as an alternative to @nub@ in @List.hs@
+nubsort :: Ord a => [a] -> SList a
+nubsort = union . map return
+
+-- | the union of a list of sorted maps
+unionMap :: Ord a => (b -> b -> b) 
+	 -> [SMap a b] -> SMap a b
+unionMap plus = foldMerge (mergeMap plus) []
+
+-- | merging two sorted maps
+mergeMap :: Ord a => (b -> b -> b) 
+	 -> SMap a b -> SMap a b -> SMap a b 
+mergeMap plus [] abs = abs
+mergeMap plus abs [] = abs
+mergeMap plus abs@(ab@(a,bs):abs') cds@(cd@(c,ds):cds')
+    = case compare a c of
+        EQ -> (a, plus bs ds) : mergeMap plus abs' cds'
+	LT -> ab : mergeMap plus abs' cds
+	GT -> cd : mergeMap plus abs  cds'
+
+-- | The union of a list of sets
+union :: Ord a => [SList a] -> SList a
+union = foldMerge (<++>) []
+
+-- | The union of two sets
+(<++>) :: Ord a => SList a -> SList a -> SList a 
+[] <++> bs = bs
+as <++> [] = as
+as@(a:as') <++> bs@(b:bs') = case compare a b of
+			       LT -> a : (as' <++> bs)
+			       GT -> b : (as  <++> bs')
+			       EQ -> a : (as' <++> bs')
+
+-- | The difference of two sets
+(<\\>) :: Ord a => SList a -> SList a -> SList a 
+[] <\\> bs = []
+as <\\> [] = as
+as@(a:as') <\\> bs@(b:bs') = case compare a b of
+			       LT -> a : (as' <\\> bs)
+			       GT ->     (as  <\\> bs')
+			       EQ ->     (as' <\\> bs')
+
+-- | The intersection of two sets
+(<**>) :: Ord a => SList a -> SList a -> SList a
+[] <**> bs = []
+as <**> [] = []
+as@(a:as') <**> bs@(b:bs') = case compare a b of
+			       LT ->     (as' <**> bs)
+			       GT ->     (as  <**> bs')
+			       EQ -> a : (as' <**> bs')
+
+-- | A fixed point iteration 
+limit :: Ord a => (a -> SList a)  -- ^ The iterator function
+      -> SList a                  -- ^ The initial set
+      -> SList a                  -- ^ The result of the iteration
+limit more start = limit' start start
+    where limit' chart agenda | null new' = chart
+			      | otherwise = limit' (chart <++> new') new'
+	      where new = union (map more agenda)
+		    new'= new <\\> chart
+
+
+
+
+
--- a/src/compiler/api/GF/Data/Str.hs
+++ b/src/compiler/api/GF/Data/Str.hs
@@ -0,0 +1,134 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Str
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:22:09 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- (Description of the module)
+-----------------------------------------------------------------------------
+
+module GF.Data.Str (
+  Str, Tok,        --- constructors no longer needed in PrGrammar
+  str2strings, str, sstr, --sstrV, str2allStrings,
+  plusStr, glueStr, --prStr, isZeroTok,
+  strTok --, allItems
+) where
+
+--import GF.Data.Operations(prQuotedString)
+import Data.List (isPrefixOf) --, intersperse, isSuffixOf
+
+-- | abstract token list type. AR 2001, revised and simplified 20\/4\/2003
+newtype Str = Str [Tok]  deriving (Read, Show, Eq, Ord)
+
+-- | notice that having both pre and post would leave to inconsistent situations:
+--
+-- > pre {"x" ; "y" / "a"} ++ post {"b" ; "a" / "x"}
+--
+-- always violates a condition expressed by the one or the other
+data Tok = 
+   TK String
+ | TN Ss [(Ss, [String])] -- ^ variants depending on next string 
+--- | TP Ss [(Ss, [String])] -- variants depending on previous string
+    deriving (Eq, Ord, Show, Read)
+
+
+-- | a variant can itself be a token list, but for simplicity only a list of strings
+-- i.e. not itself containing variants
+type Ss = [String]
+
+-- matching functions in both ways
+
+matchPrefix :: Ss -> [(Ss,[String])] -> [String] -> Ss
+matchPrefix s vs t =
+  head $ [u | t':_ <- [unmarkup t],
+              (u,as) <- vs,
+              any (`isPrefixOf` t') as]
+         ++ [s]
+{-
+matchSuffix :: String -> Ss -> [(Ss,[String])] -> Ss
+matchSuffix t s vs = 
+  head ([u | (u,as) <- vs, any (\c -> isSuffixOf c t) as] ++ [s])
+-}
+unmarkup :: [String] -> [String]
+unmarkup = filter (not . isXMLtag) where
+  isXMLtag s = case s of
+    '<':cs@(_:_) -> last cs == '>'
+    _ -> False
+
+str2strings :: Str -> Ss
+str2strings (Str st) = alls st where 
+  alls st = case st of
+    TK s     : ts   -> s                   : alls ts
+    TN ds vs : ts   -> matchPrefix ds vs t ++ t where t = alls ts
+----    u :TP ds vs: ts -> [u] ++ matchSuffix u ds vs ++ alls ts
+    []              -> []
+{-
+str2allStrings :: Str -> [Ss]
+str2allStrings (Str st) = alls st where 
+  alls st = case st of
+    TK s     : ts -> [s        : t | t <- alls ts]
+    TN ds vs : [] -> [ds      ++ v | v <- map fst vs]
+    TN ds vs : ts -> [matchPrefix ds vs t ++ t | t <- alls ts]
+    []            -> [[]]
+-}
+sstr :: Str -> String
+sstr = unwords . str2strings
+{-
+-- | to handle a list of variants
+sstrV :: [Str] -> String
+sstrV ss = case ss of
+  []  -> "*"
+  _   -> unwords $ intersperse "/" $ map (unwords . str2strings) ss
+-}
+str :: String -> Str
+str s = if null s then Str [] else Str [itS s]
+
+itS :: String -> Tok
+itS s = TK s
+{-
+isZeroTok :: Str -> Bool
+isZeroTok t = case t of
+  Str [] -> True
+  Str [TK []] -> True
+  _ -> False
+-}
+strTok :: Ss -> [(Ss,[String])] -> Str
+strTok ds vs = Str [TN ds vs]
+{-
+prStr :: Str -> String
+prStr = prQuotedString . sstr
+-}
+plusStr :: Str -> Str -> Str
+plusStr (Str ss) (Str tt) = Str (ss ++ tt)
+
+glueStr :: Str -> Str -> Str
+glueStr (Str ss) (Str tt) = Str $ case (ss,tt) of
+  ([],_) -> tt
+  (_,[]) -> ss
+  _ -> init ss ++ glueIt (last ss) (head tt) ++ tail tt
+ where
+   glueIt t u = case (t,u) of
+     (TK s, TK s') -> return $ TK $ s ++ s'
+     (TN ds vs, TN es ws) -> return $ TN (glues (matchPrefix ds vs es) es) 
+                               [(glues (matchPrefix ds vs w) w,cs) | (w,cs) <- ws]
+     (TN ds vs, TK s) -> map TK $ glues (matchPrefix ds vs [s]) [s]
+     (TK s, TN es ws) -> return $ TN (glues [s] es) [(glues [s] w, c) | (w,c) <- ws]
+
+glues :: [[a]] -> [[a]] -> [[a]]
+glues ss tt = case (ss,tt) of
+  ([],_) -> tt
+  (_,[]) -> ss
+  _ -> init ss ++ [last ss ++ head tt] ++ tail tt
+{-
+-- | to create the list of all lexical items
+allItems :: Str -> [String]
+allItems (Str s) = concatMap allOne s where
+  allOne t = case t of
+    TK s -> [s]
+    TN ds vs -> ds ++ concatMap fst vs
+-}
--- a/src/compiler/api/GF/Data/Utilities.hs
+++ b/src/compiler/api/GF/Data/Utilities.hs
@@ -0,0 +1,207 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/26 18:47:16 $
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- Basic functions not in the standard libraries
+-----------------------------------------------------------------------------
+
+
+module GF.Data.Utilities(module GF.Data.Utilities) where
+
+import Data.Maybe
+import Data.List
+import Control.Monad (MonadPlus(..),liftM,when)
+import qualified Data.Set as Set
+
+-- * functions on lists
+
+sameLength :: [a] -> [a] -> Bool
+sameLength [] [] = True
+sameLength (_:xs) (_:ys) = sameLength xs ys
+sameLength _ _ = False
+
+notLongerThan, longerThan :: Int -> [a] -> Bool
+notLongerThan n = null . snd . splitAt n
+longerThan    n = not . notLongerThan n
+
+lookupList :: Eq a => a -> [(a, b)] -> [b]
+lookupList a [] = []
+lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
+                    | otherwise  =         lookupList a ps
+
+split :: [a] -> ([a], [a])
+split (x : y : as) = (x:xs, y:ys)
+    where (xs, ys) = split as
+split as = (as, [])
+
+splitBy :: (a -> Bool) -> [a] -> ([a], [a])
+splitBy p [] = ([], [])
+splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
+    where (xs, ys) = splitBy p as
+
+foldMerge :: (a -> a -> a) -> a -> [a] -> a
+foldMerge merge zero = fm
+    where fm [] = zero
+          fm [a] = a
+          fm abs = let (as, bs) = split abs in fm as `merge` fm bs
+
+select :: [a] -> [(a, [a])]
+select [] = []
+select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ]
+
+updateNth :: (a -> a) -> Int -> [a] -> [a]
+updateNth update 0 (a : as) = update a : as
+updateNth update n (a : as) = a : updateNth update (n-1) as
+
+updateNthM :: Monad m => (a -> m a) -> Int -> [a] -> m [a]
+updateNthM update 0 (a : as) = liftM (:as) (update a)
+updateNthM update n (a : as) = liftM (a:)  (updateNthM update (n-1) as)
+
+-- | Like 'init', but returns the empty list when the input is empty.
+safeInit :: [a] -> [a]
+safeInit [] = []
+safeInit xs = init xs
+
+-- | Sorts and then groups elements given an ordering of the
+--   elements.
+sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]]
+sortGroupBy f = groupBy (compareEq f) . sortBy f
+
+-- | Take the union of a list of lists.
+unionAll :: Eq a => [[a]] -> [a]
+unionAll = nub . concat
+
+-- | Like 'lookup', but fails if the argument is not found,
+--   instead of returning Nothing.
+lookup' :: (Show a, Eq a) => a -> [(a,b)] -> b
+lookup' x = fromMaybe (error $ "Not found: " ++ show x) . lookup x
+
+-- | Like 'find', but fails if nothing is found.
+find' :: (a -> Bool) -> [a] -> a
+find' p = fromJust . find p
+
+-- | Set a value in a lookup table.
+tableSet :: Eq a => a -> b -> [(a,b)] -> [(a,b)]
+tableSet x y [] = [(x,y)]
+tableSet x y (p@(x',_):xs) | x' == x = (x,y):xs
+                           | otherwise = p:tableSet x y xs
+
+-- | Group tuples by their first elements.
+buildMultiMap :: Ord a => [(a,b)] -> [(a,[b])]
+buildMultiMap = map (\g -> (fst (head g), map snd g) )
+                 . sortGroupBy (compareBy fst)
+
+-- * equality functions
+
+-- | Use an ordering function as an equality predicate.
+compareEq :: (a -> a -> Ordering) -> a -> a -> Bool
+compareEq f x y = case f x y of
+                             EQ -> True
+                             _ -> False
+
+-- * ordering functions
+
+compareBy :: Ord b => (a -> b) -> a -> a -> Ordering
+compareBy f = both f compare
+
+both :: (a -> b) -> (b -> b -> c) -> a -> a -> c
+both f g x y = g (f x) (f y)
+
+-- * functions on pairs
+
+apFst :: (a -> a') -> (a, b) -> (a', b)
+apFst f (a, b) = (f a, b)
+
+apSnd :: (b -> b') -> (a, b) -> (a, b')
+apSnd f (a, b) = (a, f b)
+
+apBoth :: (a -> b) -> (a, a) -> (b, b)
+apBoth f (x, y) = (f x, f y)
+
+-- * functions on lists of pairs
+
+mapFst = map . apFst
+mapSnd = map . apSnd
+mapBoth = map . apBoth
+
+-- * functions on monads
+
+-- | Return the given value if the boolean is true, els return 'mzero'.
+whenMP :: MonadPlus m => Bool -> a -> m a
+whenMP b x = if b then return x else mzero
+
+whenM bm m = flip when m =<< bm
+
+repeatM m = whenM m (repeatM m)
+
+-- * functions on Maybes
+
+-- | Returns true if the argument is Nothing or Just []
+nothingOrNull :: Maybe [a] -> Bool
+nothingOrNull = maybe True null
+
+-- * functions on functions
+
+-- | Apply all the functions in the list to the argument.
+foldFuns :: [a -> a] -> a -> a
+foldFuns fs x = foldl (flip ($)) x fs
+
+-- | Fixpoint iteration.
+fix :: Eq a => (a -> a) -> a -> a
+fix f x = let x' = f x in if x' == x then x else fix f x'
+
+-- * functions on strings
+
+-- | Join a number of lists by using the given glue
+--   between the lists.
+join :: [a] -- ^ glue
+     -> [[a]] -- ^ lists to join
+     -> [a]
+join g = concat . intersperse g
+
+-- * ShowS-functions
+
+nl :: ShowS
+nl = showChar '\n'
+
+sp :: ShowS
+sp = showChar ' '
+
+wrap :: String -> ShowS -> String -> ShowS
+wrap o s c = showString o . s . showString c
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+unwordsS :: [ShowS] -> ShowS
+unwordsS = joinS " "
+
+unlinesS :: [ShowS] -> ShowS
+unlinesS = joinS "\n"
+
+joinS :: String -> [ShowS] -> ShowS
+joinS glue = concatS . intersperse (showString glue)
+
+
+
+-- | Like 'Data.List.nub', but O(n log n) instead of O(n^2), since it uses a set to lookup previous things.
+--   The result list is stable (the elements are returned in the order they occur), and lazy.
+--   Requires that the list elements can be compared by Ord.
+--   Code ruthlessly taken from <http://hpaste.org/54411>
+nub' :: Ord a => [a] -> [a]
+nub' = loop Set.empty
+    where loop _    []            = []
+          loop seen (x : xs)
+              | Set.member x seen = loop seen xs
+              | otherwise         = x : loop (Set.insert x seen) xs
+
+
+-- | Replace all occurences of an element by another element.
+replace :: Eq a => a -> a -> [a] -> [a]
+replace x y = map (\z -> if z == x then y else z)
--- a/src/compiler/api/GF/Data/XML.hs
+++ b/src/compiler/api/GF/Data/XML.hs
@@ -0,0 +1,57 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : XML
+--
+-- Utilities for creating XML documents.
+----------------------------------------------------------------------
+module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where
+
+import GF.Data.Utilities
+
+data XML = Data String | CData String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty
+ deriving (Ord,Eq,Show)
+
+type Attr = (String,String)
+
+comments :: [String] -> [XML]
+comments = map Comment
+
+showXMLDoc :: XML -> String
+showXMLDoc xml = showsXMLDoc xml ""
+
+showsXMLDoc :: XML -> ShowS
+showsXMLDoc xml = showString header . showsXML xml
+  where header = "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
+
+showsXML :: XML -> ShowS
+showsXML = showsX 0 where
+  showsX i x = ind i . case x of
+    (Data s) -> showString s
+    (CData s) -> showString "<![CDATA[" . showString s .showString "]]>"
+    (ETag t as) -> showChar '<' . showString t . showsAttrs as . showString "/>"
+    (Tag t as cs) -> 
+      showChar '<' . showString t . showsAttrs as . showChar '>' . 
+      concatS (map (showsX (i+1)) cs) . ind i . 
+      showString "</" . showString t . showChar '>'
+    (Comment c) -> showString "<!-- " . showString c . showString " -->"
+    (Empty) -> id
+  ind i = showString ("\n" ++ replicate (2*i) ' ')
+
+showsAttrs :: [Attr] -> ShowS
+showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
+
+showsAttr :: Attr -> ShowS
+showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\""
+
+escape :: String -> String
+escape = concatMap escChar
+  where
+  escChar '<'  = "&lt;"
+  escChar '>'  = "&gt;"
+  escChar '&'  = "&amp;"
+  escChar '"'  = "&quot;"
+  escChar c    = [c]
+
+bottomUpXML :: (XML -> XML) -> XML -> XML
+bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs))
+bottomUpXML f x = f x
--- a/src/compiler/api/GF/Data/Zipper.hs
+++ b/src/compiler/api/GF/Data/Zipper.hs
@@ -0,0 +1,257 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Zipper
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/11 20:27:05 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.9 $
+--
+-- Gérard Huet's zipper (JFP 7 (1997)). AR 10\/8\/2001
+-----------------------------------------------------------------------------
+
+module GF.Data.Zipper (-- * types
+	       Tr(..),
+	       Path(..),
+	       Loc(..),
+	       -- * basic (original) functions
+	       leaf,
+	       goLeft, goRight, goUp, goDown,
+	       changeLoc,
+	       changeNode,
+	       forgetNode,
+	       -- * added sequential representation
+	       goAhead,
+	       goBack,
+	       -- ** n-ary versions
+	       goAheadN,
+	       goBackN,
+	       -- * added mappings between locations and trees
+	       loc2tree,
+	       loc2treeMarked,
+	       tree2loc,
+	       goRoot,
+	       goLast,
+	       goPosition,
+	       getPosition,
+	       keepPosition,
+	       -- * added some utilities
+	       traverseCollect,
+	       scanTree,
+	       mapTr,
+	       mapTrM,
+	       mapPath,
+	       mapPathM,
+	       mapLoc,
+	       mapLocM,
+	       foldTr,
+	       foldTrM,
+	       mapSubtrees,
+	       mapSubtreesM,
+	       changeRoot,
+	       nthSubtree,
+	       arityTree
+	      ) where
+
+import GF.Data.Operations
+
+newtype Tr a = Tr (a,[Tr a]) deriving (Show,Eq)
+    
+data Path a = 
+    Top 
+  | Node ([Tr a], (Path a, a), [Tr a]) 
+   deriving Show
+
+leaf :: a -> Tr a
+leaf a = Tr (a,[])
+
+newtype Loc a = Loc (Tr a, Path a)     deriving Show
+
+goLeft, goRight, goUp, goDown :: Loc a -> Err (Loc a)
+goLeft (Loc (t,p)) = case p of
+  Top -> Bad "left of top"
+  Node (l:left, upv, right) -> return $ Loc (l, Node (left,upv,t:right))
+  Node _ -> Bad "left of first"
+goRight (Loc (t,p)) = case p of
+  Top -> Bad "right of top"
+  Node (left, upv, r:right) -> return $ Loc (r, Node (t:left,upv,right))
+  Node _ -> Bad "right of first"
+goUp (Loc (t,p)) = case p of
+  Top -> Bad "up of top"
+  Node (left, (up,v), right) -> 
+    return $ Loc (Tr (v, reverse left ++ (t:right)), up)
+goDown (Loc (t,p)) = case t of
+  Tr (v,(t1:trees)) -> return $ Loc (t1,Node ([],(p,v),trees))
+  _ -> Bad "down of empty"
+
+changeLoc :: Loc a -> Tr a -> Err (Loc a)
+changeLoc (Loc (_,p)) t = return $ Loc (t,p)
+
+changeNode :: (a -> a) -> Loc a -> Loc a
+changeNode f (Loc (Tr (n,ts),p)) = Loc (Tr (f n, ts),p)
+
+forgetNode :: Loc a -> Err (Loc a)
+forgetNode (Loc (Tr (n,[t]),p)) = return $ Loc (t,p)
+forgetNode _ = Bad $ "not a one-branch tree"
+
+-- added sequential representation
+
+-- | a successor function
+goAhead :: Loc a -> Err (Loc a) 
+goAhead s@(Loc (t,p)) = case (t,p) of
+  (Tr (_,_:_),Node (_,_,_:_)) -> goDown s
+  (Tr (_,[]), _)              -> upsRight s
+  (_,         _)              -> goDown s
+ where
+   upsRight t = case goRight t of
+     Ok t' -> return t'
+     Bad _ -> goUp t >>= upsRight
+
+-- | a predecessor function
+goBack :: Loc a -> Err (Loc a) 
+goBack s@(Loc (t,p)) = case goLeft s of
+  Ok s' -> downRight s'
+  _     -> goUp s
+ where
+   downRight s = case goDown s of
+     Ok s' -> case goRight s' of
+       Ok s'' -> downRight s''
+       _ -> downRight s'       
+     _     -> return s
+
+-- n-ary versions
+
+goAheadN :: Int ->  Loc a -> Err (Loc a)
+goAheadN i st
+  | i < 1     = return st
+  | otherwise = goAhead st >>= goAheadN (i-1)
+
+goBackN :: Int ->  Loc a -> Err (Loc a)
+goBackN i st
+  | i < 1     = return st
+  | otherwise = goBack st >>= goBackN (i-1)
+
+-- added mappings between locations and trees
+
+loc2tree :: Loc a -> Tr a
+loc2tree (Loc (t,p)) = case p of
+  Top -> t
+  Node (left,(p',v),right) -> 
+    loc2tree (Loc (Tr (v, reverse left ++ (t : right)),p'))
+
+loc2treeMarked :: Loc a -> Tr (a, Bool)
+loc2treeMarked (Loc (Tr (a,ts),p)) = 
+  loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p)) 
+ where 
+   (mark, nomark) = (\a -> (a,True), \a -> (a, False))
+
+tree2loc :: Tr a -> Loc a
+tree2loc t = Loc (t,Top)
+
+goRoot :: Loc a -> Loc a
+goRoot = tree2loc . loc2tree
+
+goLast :: Loc a -> Err (Loc a)
+goLast = rep goAhead where
+  rep f s = err (const (return s)) (rep f) (f s)
+
+goPosition :: [Int] -> Loc a -> Err (Loc a)
+goPosition p = go p . goRoot where
+  go []     s = return s
+  go (p:ps) s = goDown s >>= apply p goRight >>= go ps
+
+getPosition :: Loc a -> [Int]
+getPosition = reverse . getp where 
+  getp (Loc (t,p)) = case p of
+    Top -> []
+    Node (left,(p',v),_) -> length left : getp (Loc (Tr (v, []),p'))
+
+keepPosition :: (Loc a -> Err (Loc a)) -> (Loc a -> Err (Loc a))
+keepPosition f s = do
+  let p = getPosition s
+  s' <- f s
+  goPosition p s'
+
+apply :: Monad m => Int -> (a -> m a) -> a -> m a
+apply n f a = case n of
+  0 -> return a
+  _ -> f a >>= apply (n-1) f
+
+-- added some utilities
+
+traverseCollect :: Path a -> [a]
+traverseCollect p = reverse $ case p of
+  Top -> []
+  Node (_, (p',v), _) -> v : traverseCollect p'
+
+scanTree :: Tr a -> [a]
+scanTree (Tr (a,ts)) = a : concatMap scanTree ts
+
+mapTr :: (a -> b) -> Tr a -> Tr b
+mapTr f (Tr (x,ts)) = Tr (f x, map (mapTr f) ts)
+
+mapTrM :: Monad m => (a -> m b) -> Tr a -> m (Tr b)
+mapTrM f (Tr (x,ts)) = do
+  fx  <- f x
+  fts <- mapM (mapTrM f) ts
+  return $ Tr (fx,fts)
+
+mapPath :: (a -> b) -> Path a -> Path b
+mapPath f p = case p of
+  Node (ts1, (p,v), ts2) -> 
+    Node (map (mapTr f) ts1, (mapPath f p, f v), map (mapTr f) ts2)
+  Top -> Top
+
+mapPathM :: Monad m => (a -> m b) -> Path a -> m (Path b)
+mapPathM f p = case p of
+  Node (ts1, (p,v), ts2) -> do
+    ts1' <- mapM (mapTrM f) ts1
+    p'   <- mapPathM f p
+    v'   <- f v 
+    ts2' <- mapM (mapTrM f) ts2
+    return $ Node (ts1', (p',v'), ts2')
+  Top -> return Top
+
+mapLoc :: (a -> b) -> Loc a -> Loc b
+mapLoc f (Loc (t,p)) = Loc (mapTr f t, mapPath f p)
+
+mapLocM :: Monad m => (a -> m b) -> Loc a -> m (Loc b)
+mapLocM f (Loc (t,p)) = do
+  t' <- mapTrM f t
+  p' <- mapPathM f p
+  return $ (Loc (t',p'))
+
+foldTr :: (a -> [b] -> b) -> Tr a -> b
+foldTr f (Tr (x,ts)) = f x (map (foldTr f) ts)
+
+foldTrM :: Monad m => (a -> [b] -> m b) -> Tr a -> m b
+foldTrM f (Tr (x,ts)) = do
+  fts <- mapM (foldTrM f) ts
+  f x fts
+
+mapSubtrees :: (Tr a -> Tr a) -> Tr a -> Tr a
+mapSubtrees f t = let Tr (x,ts) = f t in Tr (x, map (mapSubtrees f) ts)
+
+mapSubtreesM :: Monad m => (Tr a -> m (Tr a)) -> Tr a -> m (Tr a)
+mapSubtreesM f t = do
+  Tr (x,ts) <- f t
+  ts' <- mapM (mapSubtreesM f) ts
+  return $ Tr (x, ts')
+
+-- | change the root without moving the pointer
+changeRoot :: (a -> a) -> Loc a -> Loc a
+changeRoot f loc = case loc of
+  Loc (Tr (a,ts),Top) -> Loc (Tr (f a,ts),Top)
+  Loc (t, Node (left,pv,right)) -> Loc (t, Node (left,chPath pv,right))
+ where
+   chPath pv = case pv of 
+     (Top,a) -> (Top, f a)
+     (Node (left,pv,right),v) -> (Node (left, chPath pv,right),v)
+
+nthSubtree :: Int -> Tr a -> Err (Tr a)
+nthSubtree n (Tr (a,ts)) = ts !? n
+
+arityTree :: Tr a -> Int
+arityTree (Tr (_,ts)) = length ts