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

14 files changed, 0 insertions, 2007 deletions

diff --git a/src/GF/Data/Assoc.hs b/src/GF/Data/Assoc.hs
deleted file mode 100644
index f775319ea..000000000
--- a/src/GF/Data/Assoc.hs
+++ /dev/null
@@ -1,143 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : Assoc
--- Maintainer  : Peter Ljunglöf
--- Stability   : Stable
--- Portability : Haskell 98
---
--- > CVS $Date: 2005/05/09 09:28:44 $ 
--- > CVS $Author: peb $
--- > CVS $Revision: 1.4 $
---
--- Association lists, or finite maps,
--- including sets as maps with result type @()@.
--- function names stolen from module @Array@.
--- /O(log n)/ key lookup
------------------------------------------------------------------------------
-
-module GF.Data.Assoc ( Assoc,
-		       Set,
-		       emptyAssoc,
-		       emptySet,
-		       listAssoc,
-		       listSet,
-		       accumAssoc,
-		       aAssocs,
-		       aElems,
-		       assocMap,
-		       assocFilter,
-		       lookupAssoc,
-		       lookupWith,
-		       (?),
-		       (?=)
-		     ) where
-
-import GF.Data.SortedList 
-
-infixl 9 ?, ?=
-
--- | a set is a finite map with empty values
-type Set a = Assoc a ()
-
-emptyAssoc :: Ord a => Assoc a b
-emptySet   :: Ord a => Set a
-
--- | creating a finite map from a sorted key-value list 
-listAssoc   :: Ord a => SList (a, b) -> Assoc a b
-
--- | creating a set from a sorted list
-listSet     :: Ord a => SList a -> Set a
-
--- | building a finite map from a list of keys and 'b's, 
--- and a function that combines a sorted list of 'b's into a value
-accumAssoc :: (Ord a, Ord c) => (SList c -> b) -> [(a, c)] -> Assoc a b
-
--- | all key-value pairs from an association list
-aAssocs :: Ord a => Assoc a b -> SList (a, b)
-
--- | all keys from an association list
-aElems  :: Ord a => Assoc a b -> SList a
-
--- fmap :: Ord a => (b -> b') -> Assoc a b -> Assoc a b'
-
--- | mapping values to other values.
--- the mapping function can take the key as information
-assocMap :: Ord a => (a -> b -> b') -> Assoc a b -> Assoc a b'
-
-assocFilter :: Ord a => (b -> Bool) -> Assoc a b -> Assoc a b
-assocFilter pred = listAssoc . filter (pred . snd) . aAssocs
-
--- | monadic lookup function,
--- returning failure if the key does not exist
-lookupAssoc :: (Ord a, Monad m) => Assoc a b -> a -> m b
-
--- | if the key does not exist, 
--- the first argument is returned
-lookupWith :: Ord a => b -> Assoc a b -> a -> b
-
--- | if the values are monadic, we can return the value type
-(?) :: (Ord a, Monad m) => Assoc a (m b) -> a -> m b
-
--- | checking wheter the map contains a given key 
-(?=) :: Ord a => Assoc a b -> a -> Bool
-
-
-------------------------------------------------------------
-
-data Assoc a b = ANil | ANode (Assoc a b) a b (Assoc a b)
-		 deriving (Eq, Ord, Show)
-
-emptyAssoc = ANil
-emptySet   = emptyAssoc
-
-listAssoc as = assoc
-  where (assoc, [])     = sl2bst (length as) as
-	sl2bst 0 xs     = (ANil, xs)
-	sl2bst 1 (x:xs) = (ANode ANil (fst x) (snd x) ANil, xs)
-	sl2bst n xs     = (ANode left (fst x) (snd x) right, zs)
-          where llen    = (n-1) `div` 2
-                rlen    = n - 1 - llen
-                (left, x:ys) = sl2bst llen xs
-                (right, zs)  = sl2bst rlen ys
-
-listSet as = listAssoc (zip as (repeat ()))
-
-accumAssoc join = listAssoc . map (mapSnd join) . groupPairs . nubsort
-    where mapSnd f (a, b) = (a, f b)
-
-aAssocs as = prs as []
-    where prs ANil = id
-	  prs (ANode left a b right) = prs left . ((a,b) :) . prs right
-
-aElems = map fst . aAssocs
-
-
-instance Ord a => Functor (Assoc a) where
-    fmap f = assocMap (const f)
-
-assocMap f ANil = ANil
-assocMap f (ANode left a b right) = ANode (assocMap f left) a (f a b) (assocMap f right)
-
-
-lookupAssoc ANil _ = fail "key not found"
-lookupAssoc (ANode left a b right) a' = case compare a a' of
-					  GT -> lookupAssoc left  a'
-					  LT -> lookupAssoc right a'
-					  EQ -> return b
-
-lookupWith z ANil _ = z
-lookupWith z (ANode left a b right) a' = case compare a a' of
-					   GT -> lookupWith z left  a'
-					   LT -> lookupWith z right a'
-					   EQ -> b
-
-(?) = lookupWith (fail "key not found")
-
-(?=) = \assoc -> maybe False (const True) . lookupAssoc assoc 
-
-
-
-
-
-
-
diff --git a/src/GF/Data/BacktrackM.hs b/src/GF/Data/BacktrackM.hs
deleted file mode 100644
index 36317ebb6..000000000
--- a/src/GF/Data/BacktrackM.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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
------------------------------------------------------------------------------
-
-{-# OPTIONS_GHC -fglasgow-exts #-}
-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.Monad
-import Control.Monad.State.Class
-
-----------------------------------------------------------------------
--- 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 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
-    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 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)
diff --git a/src/GF/Data/ErrM.hs b/src/GF/Data/ErrM.hs
deleted file mode 100644
index e8cea12d4..000000000
--- a/src/GF/Data/ErrM.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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
------------------------------------------------------------------------------
-
-module GF.Data.ErrM (Err(..)) where
-
-import Control.Monad (MonadPlus(..))
-
--- | like @Maybe@ type with error msgs
-data Err a = Ok a | Bad String
-  deriving (Read, Show, Eq)
-
-instance Monad Err where
-  return      = Ok
-  fail        = Bad
-  Ok a  >>= f = f a
-  Bad s >>= f = Bad s
-
--- | added 2\/10\/2003 by PEB
-instance Functor Err where
-  fmap f (Ok a) = Ok (f a)
-  fmap f (Bad s) = Bad s
-
--- | added by KJ
-instance MonadPlus Err where
-    mzero = Bad "error (no reason given)"
-    mplus (Ok a)  _ = Ok a
-    mplus (Bad s) b = b
diff --git a/src/GF/Data/Graph.hs b/src/GF/Data/Graph.hs
deleted file mode 100644
index bfb289860..000000000
--- a/src/GF/Data/Graph.hs
+++ /dev/null
@@ -1,178 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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
diff --git a/src/GF/Data/Graphviz.hs b/src/GF/Data/Graphviz.hs
deleted file mode 100644
index 411f76898..000000000
--- a/src/GF/Data/Graphviz.hs
+++ /dev/null
@@ -1,116 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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
diff --git a/src/GF/Data/MultiMap.hs b/src/GF/Data/MultiMap.hs
deleted file mode 100644
index e565f433b..000000000
--- a/src/GF/Data/MultiMap.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-module GF.Data.MultiMap where
-
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Prelude hiding (map)
-import qualified Prelude
-
-type MultiMap k a = Map k (Set a)
-
-empty :: MultiMap k a
-empty = Map.empty
-
-keys :: MultiMap k a -> [k]
-keys = Map.keys
-
-elems :: MultiMap k a -> [a]
-elems = concatMap Set.toList . Map.elems
-
-(!) :: Ord k => MultiMap k a -> k -> [a]
-m ! k = Set.toList $ Map.findWithDefault Set.empty k m
-
-member :: (Ord k, Ord a) => k -> a -> MultiMap k a -> Bool
-member k x m = x `Set.member` Map.findWithDefault Set.empty k m
-
-insert :: (Ord k, Ord a) => k -> a -> MultiMap k a -> MultiMap k a
-insert k x m = Map.insertWith Set.union k (Set.singleton x) m
-
-insert' :: (Ord k, Ord a) => k -> a -> MultiMap k a -> Maybe (MultiMap k a)
-insert' k x m | member k x m = Nothing -- FIXME: inefficient
-              | otherwise = Just (insert k x m)
-
-union :: (Ord k, Ord a) => MultiMap k a -> MultiMap k a -> MultiMap k a
-union = Map.unionWith Set.union
-
-size :: MultiMap k a -> Int
-size = sum . Prelude.map Set.size . Map.elems
-
-map :: (Ord a, Ord b) => (a -> b) -> MultiMap k a -> MultiMap k b
-map f = Map.map (Set.map f)
-
-fromList :: (Ord k, Ord a) => [(k,a)] -> MultiMap k a
-fromList xs = Map.fromListWith Set.union [(k, Set.singleton x) | (k,x) <- xs]
-
-toList :: MultiMap k a -> [(k,a)]
-toList m = [(k,x) | (k,s) <- Map.toList m, x <- Set.toList s]
\ No newline at end of file
diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs
deleted file mode 100644
index 7b2afc9fe..000000000
--- a/src/GF/Data/Operations.hs
+++ /dev/null
@@ -1,374 +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, 
-		   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"
diff --git a/src/GF/Data/Relation.hs b/src/GF/Data/Relation.hs
deleted file mode 100644
index 7024a482c..000000000
--- a/src/GF/Data/Relation.hs
+++ /dev/null
@@ -1,193 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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) 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
\ No newline at end of file
diff --git a/src/GF/Data/SortedList.hs b/src/GF/Data/SortedList.hs
deleted file mode 100644
index d77ff68d4..000000000
--- a/src/GF/Data/SortedList.hs
+++ /dev/null
@@ -1,127 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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
-
-
-
-
-
diff --git a/src/GF/Data/Str.hs b/src/GF/Data/Str.hs
deleted file mode 100644
index 6f65764c7..000000000
--- a/src/GF/Data/Str.hs
+++ /dev/null
@@ -1,134 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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 needed in PrGrammar 
-  str2strings, str2allStrings, str, sstr, sstrV, 
-  isZeroTok, prStr, plusStr, glueStr,
-  strTok, 
-  allItems
-) where
-
-import GF.Data.Operations
-import Data.List (isPrefixOf, isSuffixOf, intersperse)
-
--- | 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 | 
-    (u,as) <- vs, 
-    any (\c -> isPrefixOf c (concat (unmarkup 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
diff --git a/src/GF/Data/TrieMap.hs b/src/GF/Data/TrieMap.hs
deleted file mode 100644
index a6749d641..000000000
--- a/src/GF/Data/TrieMap.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-module GF.Data.TrieMap

-         ( TrieMap

-

-         , empty

-         , singleton

-

-         , lookup

-         

-         , null

-         , decompose

-         

-         , insertWith

-

-         , unionWith

-         , unionsWith

-         

-         , elems

-         ) where

-

-import Prelude hiding (lookup, null)

-import qualified Data.Map as Map

-

-data TrieMap k v = Tr (Maybe v) (Map.Map k (TrieMap k v))

-

-empty = Tr Nothing Map.empty

-

-singleton :: [k] -> a -> TrieMap k a

-singleton []     v = Tr (Just v) Map.empty

-singleton (k:ks) v = Tr Nothing  (Map.singleton k (singleton ks v))

-

-lookup :: Ord k => [k] -> TrieMap k a -> Maybe a

-lookup []     (Tr mb_v m) = mb_v

-lookup (k:ks) (Tr mb_v m) = Map.lookup k m >>= lookup ks

-

-null :: TrieMap k v -> Bool

-null (Tr Nothing m) = Map.null m

-null _              = False

-

-decompose :: TrieMap k v -> (Maybe v, Map.Map k (TrieMap k v))

-decompose (Tr mb_v m) = (mb_v,m)

-

-insertWith :: Ord k => (v -> v -> v) -> [k] -> v -> TrieMap k v -> TrieMap k v

-insertWith f []     v0 (Tr mb_v m) = case mb_v of

-                                       Just  v -> Tr (Just (f v0 v)) m

-                                       Nothing -> Tr (Just v0      ) m

-insertWith f (k:ks) v0 (Tr mb_v m) = case Map.lookup k m of

-                                       Nothing -> Tr mb_v (Map.insert k (singleton ks v0) m)

-                                       Just tr -> Tr mb_v (Map.insert k (insertWith f ks v0 tr) m)

-

-unionWith :: Ord k => (v -> v -> v) -> TrieMap k v -> TrieMap k v -> TrieMap k v

-unionWith f (Tr mb_v1 m1) (Tr mb_v2 m2) =

-  let mb_v = case (mb_v1,mb_v2) of

-               (Nothing,Nothing) -> Nothing

-               (Just v ,Nothing) -> Just v

-               (Nothing,Just v ) -> Just v

-               (Just v1,Just v2) -> Just (f v1 v2)

-      m    = Map.unionWith (unionWith f) m1 m2

-  in Tr mb_v m

-

-unionsWith :: Ord k => (v -> v -> v) -> [TrieMap k v] -> TrieMap k v

-unionsWith f = foldl (unionWith f) empty

-

-elems :: TrieMap k v -> [v]

-elems tr = collect tr []

-  where

-    collect (Tr mb_v m) xs = maybe id (:) mb_v (Map.fold collect xs m)

diff --git a/src/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs
deleted file mode 100644
index 74d3ef81e..000000000
--- a/src/GF/Data/Utilities.hs
+++ /dev/null
@@ -1,190 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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 where
-
-import Data.Maybe
-import Data.List
-import Control.Monad (MonadPlus(..),liftM)
-
--- * 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
-
--- | Like 'nub', but more efficient as it uses sorting internally.
-sortNub :: Ord a => [a] -> [a]
-sortNub = map head . group . sort
-
--- | Like 'nubBy', but more efficient as it uses sorting internally.
-sortNubBy :: (a -> a -> Ordering) -> [a] -> [a]
-sortNubBy f = map head . sortGroupBy f
-
--- | Sorts and then groups elements given and 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)
-
--- | 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)
-
--- * 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
-
-mapFst :: (a -> a') -> (a, b) -> (a', b)
-mapFst f (a, b) = (f a, b)
-
-mapSnd :: (b -> b') -> (a, b) -> (a, b')
-mapSnd f (a, b) = (a, f b)
-
--- * 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
-
--- * 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)
-
-
-
diff --git a/src/GF/Data/XML.hs b/src/GF/Data/XML.hs
deleted file mode 100644
index bdc6f98a1..000000000
--- a/src/GF/Data/XML.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : XML
---
--- Utilities for creating XML documents.
-----------------------------------------------------------------------
-module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where
-
-import GF.Data.Utilities
-import GF.Text.UTF8
-
-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 = encodeUTF8 . 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
diff --git a/src/GF/Data/Zipper.hs b/src/GF/Data/Zipper.hs
deleted file mode 100644
index a4491f76e..000000000
--- a/src/GF/Data/Zipper.hs
+++ /dev/null
@@ -1,257 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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