Founding the newly structured GF2.0 cvs archive.

7 files changed, 1216 insertions, 0 deletions

diff --git a/src/GF/Data/ErrM.hs b/src/GF/Data/ErrM.hs
new file mode 100644
index 000000000..eb2078718
--- /dev/null
+++ b/src/GF/Data/ErrM.hs
@@ -0,0 +1,7 @@
+module ErrM (
+  module Operations
+) where
+
+import Operations
+
+-- hack for BNFC generated files. AR 21/9/2003
diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs
new file mode 100644
index 000000000..7110a7ac0
--- /dev/null
+++ b/src/GF/Data/Operations.hs
@@ -0,0 +1,559 @@
+module Operations where
+
+import Char  (isSpace, toUpper, isSpace, isDigit)
+import List  (nub, sortBy, sort, deleteBy, nubBy)
+import Monad (liftM2)
+
+infixr 5 +++
+infixr 5 ++-
+infixr 5 ++++
+infixr 5 +++++
+infixl 9 !?
+
+-- some auxiliary GF operations. AR 19/6/1998 -- 6/2/2001
+-- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL)
+
+ifNull :: b -> ([a] -> b) -> [a] -> b
+ifNull b f xs = if null xs then b else f xs
+  
+-- the Error monad
+
+data Err a = Ok a | Bad String   -- like Maybe type with error msgs
+  deriving (Read, Show, Eq)
+
+instance Monad Err where
+  return      = Ok
+  Ok a  >>= f = f a
+  Bad s >>= f = Bad s
+
+-- analogue of maybe
+err :: (String -> b) -> (a -> b) -> Err a -> b 
+err d f e = case e of
+  Ok a -> f a
+  Bad s -> d s
+
+-- add msg s to Maybe failures
+maybeErr :: String -> Maybe a -> Err a
+maybeErr s = maybe (Bad s) Ok
+
+testErr :: Bool -> String -> Err ()
+testErr cond msg = if cond then return () else Bad msg
+
+errVal :: a -> Err a -> a
+errVal a = err (const a) id
+
+errIn :: String -> Err a -> Err a
+errIn msg = err (\s -> Bad (s ++++ "OCCURRED IN" ++++ msg)) return
+
+-- used for extra error reports when developing GF
+derrIn :: String -> Err a -> Err a
+derrIn m = errIn m -- id
+
+performOps :: [a -> Err a] -> a -> Err a
+performOps ops a = case ops of
+  f:fs -> f a >>= performOps fs
+  [] -> return a
+
+repeatUntilErr :: (a -> Bool) -> (a -> Err a) -> a -> Err a
+repeatUntilErr cond f a = if cond a then return a else f a >>= repeatUntilErr cond f
+
+repeatUntil :: (a -> Bool) -> (a -> a) -> a -> a
+repeatUntil cond f a = if cond a then a else repeatUntil cond f (f a)
+
+okError :: Err a -> a
+okError = err (error "no result Ok") id
+
+isNotError :: Err a -> Bool
+isNotError = err (const False) (const True)
+
+showBad :: Show a => String -> a -> Err b
+showBad s a = Bad (s +++ show a)
+
+lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err b
+lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs)
+
+lookupErrMsg :: (Eq a,Show a) => String -> a -> [(a,b)] -> Err b
+lookupErrMsg m a abs = maybeErr (m +++ "gave unknown" +++ show a) (lookup a abs)
+
+lookupDefault :: Eq a => b -> a -> [(a,b)] -> b
+lookupDefault d x l = maybe d id $  lookup x l 
+
+updateLookupList ::  Eq a => (a,b) -> [(a,b)] -> [(a,b)]
+updateLookupList ab abs = insert ab [] abs where
+ insert c cc [] = cc ++ [c]
+ insert (a,b) cc ((a',b'):cc') = if   a == a' 
+                                 then cc ++ [(a,b)] ++ cc'
+                                 else insert (a,b) (cc ++ [(a',b')]) cc'
+
+mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)]
+mapPairListM f xys =
+  do yy' <- mapM f xys
+     return (zip (map fst xys) yy')
+
+mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
+mapPairsM f xys =
+  do let (xx,yy) = unzip xys
+     yy' <- mapM f yy
+     return (zip xx yy')
+
+pairM :: Monad a => (b -> a c) -> (b,b) -> a (c,c)
+pairM op (t1,t2) = liftM2 (,) (op t1) (op t2)
+
+-- like mapM, but continue instead of halting with Err
+mapErr :: (a -> Err b) -> [a] -> Err ([b], String) 
+mapErr f xs = Ok (ys, unlines ss) 
+  where
+    (ys,ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs])
+    fxs = map f xs
+
+-- !! with the error monad
+(!?) :: [a] -> Int -> Err a
+xs !? i = foldr (const . return) (Bad "too few elements in list") $ drop i xs
+
+errList :: Err [a] -> [a]
+errList = errVal []
+
+singleton :: a -> [a]
+singleton = (:[])
+
+-- checking
+
+checkUnique :: (Show a, Eq a) => [a] -> [String]
+checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where
+  overloads = filter overloaded ss
+  overloaded s = length (filter (==s) ss) > 1
+
+titleIfNeeded :: a -> [a] -> [a]
+titleIfNeeded a [] = []
+titleIfNeeded a as = a:as
+
+errMsg :: Err a -> [String]
+errMsg (Bad m) = [m]
+errMsg _ = []
+
+errAndMsg :: Err a -> Err (a,[String])
+errAndMsg (Bad m) = Bad m
+errAndMsg (Ok a) = return (a,[])
+
+-- a three-valued maybe type to express indirections
+
+data Perhaps a b = Yes a | May b | Nope deriving (Show,Read,Eq,Ord)
+
+yes = Yes
+may = May
+nope = Nope
+
+mapP :: (a -> c) -> Perhaps a b -> Perhaps c b
+mapP f p = case p of
+  Yes a -> Yes (f a)
+  May b -> May b
+  Nope  -> Nope
+
+-- this is what happens when matching two values in the same module
+unifPerhaps :: Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
+unifPerhaps p1 p2 = case (p1,p2) of
+  (Nope, _)  -> return p2
+  (_, Nope)  -> return p1
+  _ -> Bad "update conflict"
+
+-- this is what happens when updating a module extension
+updatePerhaps :: b -> Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
+updatePerhaps old p1 p2 = case (p1,p2) of
+  (Yes a,    Nope)  -> return $ may old
+  (May older,Nope)  -> return $ may older
+  (_, May a)        -> Bad "strange indirection"
+  _ -> unifPerhaps p1 p2
+
+-- binary search trees
+
+data BinTree a = NT | BT a (BinTree a) (BinTree a) deriving (Show,Read)
+
+isInBinTree :: (Ord a) => a -> BinTree a -> Bool
+isInBinTree x tree = case tree of
+ NT -> False
+ BT a left right 
+   | x < a  -> isInBinTree x left
+   | x > a  -> isInBinTree x right
+   | x == a -> True
+
+-- quick method to see if two trees have common elements
+-- the complexity is O(log |old|, |new|) so the heuristic is that new is smaller
+
+commonsInTree :: (Ord a) => BinTree (a,b) -> BinTree (a,b) -> [(a,(b,b))]
+commonsInTree old new = foldr inOld [] new' where
+  new' = tree2list new
+  inOld (x,v) xs = case justLookupTree x old of
+    Ok v' -> (x,(v',v)) : xs
+    _ -> xs
+
+justLookupTree :: (Ord a) => a -> BinTree (a,b) -> Err b
+justLookupTree = lookupTree (const [])
+
+lookupTree :: (Ord a) => (a -> String) -> a -> BinTree (a,b) -> Err b
+lookupTree pr x tree = case tree of
+ NT -> Bad ("no occurrence of element" +++ pr x)
+ BT (a,b) left right 
+   | x < a  -> lookupTree pr x left
+   | x > a  -> lookupTree pr x right
+   | x == a -> return b
+
+lookupTreeEq :: (Ord a) => 
+     (a -> String) -> (a -> a -> Bool) -> a -> BinTree (a,b) -> Err b
+lookupTreeEq pr eq x tree = case tree of
+ NT -> Bad ("no occurrence of element equal to" +++ pr x)
+ BT (a,b) left right 
+   | eq x a -> return b     -- a weaker equality relation than ==
+   | x < a  -> lookupTreeEq pr eq x left
+   | x > a  -> lookupTreeEq pr eq x right
+
+lookupTreeMany :: Ord a => (a -> String) -> [BinTree (a,b)] -> a -> Err b
+lookupTreeMany pr (t:ts) x = case lookupTree pr x t of
+  Ok v -> return v
+  _ -> lookupTreeMany pr ts x
+lookupTreeMany pr [] x = Bad $ "failed to find" +++ pr x
+
+-- destructive update
+
+updateTree :: (Ord a) => (a,b) -> BinTree (a,b) -> BinTree (a,b)
+updateTree = updateTreeGen True
+
+-- destructive or not
+
+updateTreeGen :: (Ord a) => Bool -> (a,b) -> BinTree (a,b) -> BinTree (a,b)
+updateTreeGen destr z@(x,y) tree = case tree of
+ NT -> BT z NT NT
+ BT c@(a,b) left right 
+   | x < a  -> let left' = updateTree z left in   BT c left' right 
+   | x > a  -> let right' = updateTree z right in BT c left right' 
+   | otherwise -> if destr
+                    then BT z left right -- removing the old value of a
+                    else tree            -- retaining the old value if one exists
+
+updateTreeEq :: 
+  (Ord a) => (a -> a -> Bool) -> (a,b) -> BinTree (a,b) -> BinTree (a,b)
+updateTreeEq eq z@(x,y) tree = case tree of
+ NT -> BT z NT NT
+ BT c@(a,b) left right
+   | eq x a -> BT (a,y) left right -- removing the old value of a 
+   | x < a  -> let left' = updateTree z left in   BT c left' right 
+   | x > a  -> let right' = updateTree z right in BT c left right' 
+
+updatesTree :: (Ord a) => [(a,b)] -> BinTree (a,b) -> BinTree (a,b)
+updatesTree (z:zs) tr = updateTree z t where t = updatesTree zs tr
+updatesTree [] tr = tr
+
+updatesTreeNondestr :: (Ord a) => [(a,b)] -> BinTree (a,b) -> BinTree (a,b)
+updatesTreeNondestr xs tr = case xs of
+  (z:zs) -> updateTreeGen False z t where t = updatesTreeNondestr zs tr
+  _ -> tr
+
+buildTree :: (Ord a) => [(a,b)] -> BinTree (a,b)
+buildTree = sorted2tree . sortBy fs where
+  fs (x,_) (y,_) 
+    | x < y = LT
+    | x > y = GT
+    | True  = EQ 
+-- buildTree zz = updatesTree zz NT
+
+sorted2tree :: [(a,b)] -> BinTree (a,b)
+sorted2tree [] = NT
+sorted2tree xs = BT x (sorted2tree t1) (sorted2tree t2) where
+  (t1,(x:t2)) = splitAt (length xs `div` 2) xs
+
+mapTree :: (a -> b) -> BinTree a -> BinTree b
+mapTree f NT = NT
+mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right)
+
+mapMTree :: Monad m => (a -> m b) -> BinTree a -> m (BinTree b)
+mapMTree f NT = return NT
+mapMTree f (BT a left right) = do
+ a'     <- f a
+ left'  <- mapMTree f left 
+ right' <- mapMTree f right
+ return $ BT a' left' right'
+
+tree2list :: BinTree a -> [a] -- inorder
+tree2list NT = []
+tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right
+
+depthTree :: BinTree a -> Int
+depthTree NT = 0
+depthTree (BT _ left right) = 1 + max (depthTree left) (depthTree right)
+
+mergeTrees :: Ord a => BinTree (a,b) -> BinTree (a,b) -> BinTree (a,[b])
+mergeTrees old new = foldr upd new' (tree2list old) where
+  upd xy@(x,y) tree = case tree of
+    NT -> BT (x,[y]) NT NT
+    BT (a,bs) left right 
+      | x < a  -> let left'  = upd xy left  in BT (a,bs) left' right 
+      | x > a  -> let right' = upd xy right in BT (a,bs) left  right' 
+      | otherwise -> BT (a, y:bs) left right -- adding the new value
+  new' = mapTree (\ (i,d) -> (i,[d])) new
+
+
+-- parsing
+
+type WParser a b = [a] -> [(b,[a])] -- old Wadler style parser
+
+wParseResults :: WParser a b -> [a] -> [b]
+wParseResults p aa = [b | (b,[]) <- p aa]
+
+-- printing
+
+indent :: Int -> String -> String
+indent i s = replicate i ' ' ++ s
+
+a +++ b   = a ++ " "    ++ b
+a ++- ""  = a 
+a ++- b   = a +++ b
+a ++++ b  = a ++ "\n"   ++ b
+a +++++ b = a ++ "\n\n" ++ b
+
+prUpper :: String -> String
+prUpper s = s1 ++ s2' where
+ (s1,s2) = span isSpace s
+ s2' = case s2 of
+   c:t -> toUpper c : t
+   _ -> s2
+
+prReplicate n s = concat (replicate n s)
+
+prTList t ss = case ss of
+  []   -> ""
+  [s]  -> s
+  s:ss -> s ++ t ++ prTList t ss
+
+prQuotedString x = "\"" ++ restoreEscapes x ++ "\""
+
+prParenth s = if s == "" then "" else "(" ++ s ++ ")"
+
+prCurly   s = "{" ++ s ++ "}"
+prBracket s = "[" ++ s ++ "]"
+
+prArgList xx = prParenth (prTList "," xx)
+
+prSemicList = prTList " ; "
+
+prCurlyList = prCurly . prSemicList
+
+restoreEscapes s = 
+  case s of 
+    []       -> []
+    '"' : t  -> '\\' : '"'  : restoreEscapes t
+    '\\': t  -> '\\' : '\\' : restoreEscapes t
+    c   : t  -> c : restoreEscapes t
+
+numberedParagraphs :: [[String]] -> [String]
+numberedParagraphs t = case t of 
+  []   -> []
+  p:[] -> p
+  _    -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t]
+
+prConjList :: String -> [String] -> String
+prConjList c []     = ""
+prConjList c [s]    = s
+prConjList c [s,t]  = s +++ c +++ t
+prConjList c (s:tt) = s ++ "," +++ prConjList c tt
+
+prIfEmpty :: String -> String -> String -> String -> String
+prIfEmpty em _    _    [] = em
+prIfEmpty em nem1 nem2 s  = nem1 ++ s ++ nem2
+
+-- Thomas Hallgren's wrap lines
+--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id
+wrapLines n "" = ""
+wrapLines n s@(c:cs) =
+      if isSpace c
+      then c:wrapLines (n+1) cs
+      else case lex s of
+            [(w,rest)] -> if n'>=76
+                          then '\n':w++wrapLines l rest
+                          else w++wrapLines n' rest
+               where n' = n+l
+                     l = length w
+            _ -> s -- give up!!
+
+-- LaTeX code producing functions
+
+dollar s = '$' : s ++ "$"
+mbox s   = "\\mbox{" ++ s ++ "}"
+ital s   = "{\\em" +++ s ++ "}"
+boldf s  = "{\\bf" +++ s ++ "}"
+verbat s = "\\verbat!" ++ s ++ "!"
+
+mkLatexFile s = begindocument +++++ s +++++ enddocument
+
+begindocument =
+ "\\documentclass[a4paper,11pt]{article}" ++++ -- M.F. 25/01-02
+ "\\setlength{\\parskip}{2mm}" ++++
+ "\\setlength{\\parindent}{0mm}" ++++
+ "\\setlength{\\oddsidemargin}{0mm}" ++++
+ "\\setlength{\\evensidemargin}{-2mm}" ++++
+ "\\setlength{\\topmargin}{-8mm}" ++++
+ "\\setlength{\\textheight}{240mm}" ++++
+ "\\setlength{\\textwidth}{158mm}" ++++
+ "\\begin{document}\n"
+
+enddocument =
+ "\n\\end{document}\n"
+
+sortByLongest :: [[a]] -> [[a]]
+sortByLongest = sortBy longer where
+ longer x y 
+  | x' > y' = LT
+  | x' < y' = GT
+  | True    = EQ
+  where
+   x' = length x
+   y' = length y
+
+combinations :: [[a]] -> [[a]]
+combinations t = case t of 
+  []    -> [[]]
+  aa:uu -> [a:u | a <- aa, u <- combinations uu]
+
+mkTextFile :: String -> IO ()
+mkTextFile name = do
+  s <- readFile name
+  let s' = prelude name ++ "\n\n" ++ heading name  ++ "\n" ++ object s
+  writeFile (name ++ ".hs") s'
+ where
+   prelude name = "module " ++ name ++ " where" 
+   heading name = "txt" ++ name ++ " ="
+   object s = mk s ++ " \"\""
+   mk s = unlines ["  \"" ++ escs line ++ "\" ++ \"\\n\" ++" | line <- lines s]
+   escs s = case s of
+     c:cs | elem c "\"\\" -> '\\' : c : escs cs
+     c:cs -> c : escs cs
+     _ -> s
+
+initFilePath :: FilePath -> FilePath
+initFilePath f = reverse (dropWhile (/='/') (reverse f))
+
+-- topological sorting with test of cyclicity
+
+topoTest :: Eq a => [(a,[a])] -> Either [a] [[a]]
+topoTest g = if length g' == length g then Left g' else Right (cyclesIn g ++[[]]) 
+  where
+    g' = topoSort g
+  
+cyclesIn :: Eq a => [(a,[a])] -> [[a]]
+cyclesIn deps = nubb $ clean $ filt $ iterFix findDep immediate where
+  immediate = [[y,x] | (x,xs) <- deps, y <- xs] 
+  findDep chains = [y:x:chain | 
+                      x:chain <- chains, (x',xs) <- deps, x' == x, y <- xs, 
+                      notElem y (init chain)]
+
+  clean = map remdup
+  nubb = nubBy (\x y -> y == reverse x) 
+  filt = filter (\xs -> last xs == head xs)
+  remdup (x:xs) = x : remdup xs' where xs' = dropWhile (==x) xs
+  remdup [] = []
+
+
+
+topoSort :: Eq a => [(a,[a])] -> [a]
+topoSort g = reverse $ tsort 0 [ffs | ffs@(f,_) <- g, inDeg f == 0] [] where
+  tsort _ []     r = r
+  tsort k (ffs@(f,fs) : cs) r
+    | elem f r  = tsort k cs r
+    | k > lx    = r  
+    | otherwise = tsort (k+1) cs (f : tsort (k+1) (info fs) r)
+  info hs = [(f,fs) | (f,fs) <- g, elem f hs]
+  inDeg f = length [t | (h,hs) <- g, t <- hs, t == f]
+  lx = length g
+
+-- the generic fix point iterator
+
+iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
+iterFix more start = iter start start 
+  where
+    iter old new = if (null new')
+                      then old
+                      else iter (new' ++ old) new'
+      where
+        new' = filter (`notElem` old) (more new)
+
+-- association lists
+
+updateAssoc :: Eq a => (a,b) -> [(a,b)] -> [(a,b)]
+updateAssoc ab@(a,b) as = case as of
+  (x,y): xs | x == a -> (a,b):xs
+  xy   : xs          -> xy : updateAssoc ab xs
+  []                 -> [ab]
+
+removeAssoc :: Eq a => a -> [(a,b)] -> [(a,b)]
+removeAssoc a = filter ((/=a) . fst)
+
+-- chop into separator-separated parts
+
+chunks :: String -> [String] -> [[String]]
+chunks sep ws = case span (/= sep) ws of
+  (a,_:b) -> a : bs where bs = chunks sep b
+  (a, []) -> if null a then [] else [a]
+
+readIntArg :: String -> Int
+readIntArg n = if (not (null n) && all isDigit n) then read n else 0
+
+
+-- state monad with error; from Agda 6/11/2001
+
+newtype STM s a = STM (s -> Err (a,s)) 
+
+appSTM :: STM s a -> s -> Err (a,s)
+appSTM (STM f) s = f s
+
+stm :: (s -> Err (a,s)) -> STM s a
+stm = STM
+
+stmr :: (s -> (a,s)) -> STM s a
+stmr f = stm (\s -> return (f s))
+
+instance  Monad (STM s) where
+  return a    = STM (\s -> return (a,s))
+  STM c >>= f = STM (\s -> do 
+                        (x,s') <- c s
+                        let STM f' = f x
+                        f' s')
+
+readSTM :: STM s s
+readSTM = stmr (\s -> (s,s))
+
+updateSTM :: (s -> s) -> STM s () 
+updateSTM f = stmr (\s -> ((),f s))
+
+writeSTM :: s -> STM s ()
+writeSTM s = stmr (const ((),s))
+
+done :: Monad m => m ()
+done = return ()
+
+class Monad m => ErrorMonad m where
+  raise   :: String -> m a
+  handle  :: m a -> (String -> m a) -> m a
+  handle_ :: m a -> m a -> m a
+  handle_ a b =  a `handle` (\_ -> b)
+
+instance ErrorMonad Err where
+  raise  = Bad
+  handle a@(Ok _) _ = a
+  handle (Bad i) f  = f i
+
+instance ErrorMonad (STM s) where
+  raise msg = STM (\s -> raise msg)
+  handle (STM f) g = STM (\s -> (f s) 
+                                `handle` (\e -> let STM g' = (g e) in
+                                                    g' s))
+-- if the first check fails try another one
+checkAgain :: ErrorMonad m => m a -> m a -> m a
+checkAgain c1 c2 = handle_ c1 c2
+
+checks :: ErrorMonad m => [m a] -> m a
+checks [] = raise "no chance to pass"
+checks cs = foldr1 checkAgain cs
+
+allChecks :: ErrorMonad m => [m a] -> m [a]
+allChecks ms = case ms of
+  (m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs
+  _ -> return []
+
diff --git a/src/GF/Data/OrdMap2.hs b/src/GF/Data/OrdMap2.hs
new file mode 100644
index 000000000..f41d33139
--- /dev/null
+++ b/src/GF/Data/OrdMap2.hs
@@ -0,0 +1,118 @@
+
+
+--------------------------------------------------
+-- The class of ordered finite maps
+-- as described in section 2.2.2
+
+-- and an example implementation, 
+-- derived from the implementation in appendix A.2
+
+
+module OrdMap2 (OrdMap(..), Map) where
+
+import List (intersperse)
+
+
+--------------------------------------------------
+-- the class of ordered finite maps
+
+class OrdMap m where
+  emptyMap     :: Ord s => m s a
+  (|->)        :: Ord s => s -> a -> m s a
+  isEmptyMap   :: Ord s => m s a -> Bool
+  (?)          :: Ord s => m s a -> s -> Maybe a
+  lookupWith   :: Ord s => a -> m s a -> s -> a
+  mergeWith    :: Ord s => (a -> a -> a) -> m s a -> m s a -> m s a
+  unionMapWith :: Ord s => (a -> a -> a) -> [m s a] -> m s a
+  makeMapWith  :: Ord s => (a -> a -> a) -> [(s,a)] -> m s a
+  assocs       :: Ord s => m s a -> [(s,a)]
+  ordMap       :: Ord s => [(s,a)] -> m s a
+  mapMap       :: Ord s => (a -> b) -> m s a -> m s b
+
+  lookupWith z m s = case m ? s of
+		       Just a  -> a
+		       Nothing -> z
+
+  unionMapWith join = union
+    where union []   = emptyMap
+	  union [xs] = xs
+	  union xyss = mergeWith join (union xss) (union yss)
+	    where (xss, yss)       = split xyss
+		  split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys)
+		  split xs         = (xs, [])
+
+
+--------------------------------------------------
+-- finite maps as ordered associaiton lists, 
+-- paired with binary search trees
+
+data Map s a = Map [(s,a)] (TreeMap s a)
+
+instance (Eq s, Eq a) => Eq (Map s a) where
+  Map xs _ == Map ys _ = xs == ys
+
+instance (Show s, Show a) => Show (Map s a) where
+  show (Map ass _) = "{" ++ concat (intersperse "," (map show' ass)) ++ "}"
+    where show' (s,a) = show s ++ "|->" ++ show a
+
+instance OrdMap Map where
+  emptyMap = Map []      (makeTree [])
+  s |-> a  = Map [(s,a)] (makeTree [(s,a)])
+
+  isEmptyMap (Map ass _) = null ass
+  
+  Map _ tree ? s = lookupTree s tree
+
+  mergeWith join (Map xss _) (Map yss _) = Map xyss (makeTree xyss)
+    where xyss          = merge xss yss
+	  merge []  yss = yss
+	  merge xss []  = xss
+	  merge xss@(x@(s,x'):xss') yss@(y@(t,y'):yss')
+		= case compare s t of
+		    LT -> x : merge xss' yss
+		    GT -> y : merge xss  yss'
+		    EQ -> (s, join x' y') : merge xss' yss'
+
+  makeMapWith join []      = emptyMap
+  makeMapWith join [(s,a)] = s |-> a
+  makeMapWith join xyss    = mergeWith join (makeMapWith join xss) (makeMapWith join yss)
+    where (xss, yss)       = split xyss
+	  split (x:y:xys)  = let (xs, ys) = split xys in (x:xs, y:ys)
+	  split xs         = (xs, [])
+
+  assocs (Map xss _) = xss
+  ordMap xss         = Map xss (makeTree xss)
+
+  mapMap f (Map ass atree) = Map [ (s,f a) | (s,a) <- ass ] (mapTree f atree)
+
+
+--------------------------------------------------
+-- binary search trees
+-- for logarithmic lookup time
+
+data TreeMap s a = Nil | Node (TreeMap s a) s a (TreeMap s a)
+
+makeTree ass = tree
+  where
+    (tree,[])            = sl2bst (length ass) ass
+    sl2bst 0 ass         = (Nil, ass)
+    sl2bst 1 ((s,a):ass) = (Node Nil s a Nil, ass)
+    sl2bst n ass         = (Node ltree s a rtree, css)
+      where llen = (n-1) `div` 2
+            rlen = n - 1 - llen
+            (ltree, (s,a):bss) = sl2bst llen ass
+            (rtree, css)       = sl2bst rlen bss
+
+lookupTree s Nil = Nothing
+lookupTree s (Node left s' a right) 
+    = case compare s s' of
+        LT -> lookupTree s left 
+        GT -> lookupTree s right 
+        EQ -> Just a
+
+mapTree f Nil = Nil
+mapTree f (Node left s a right) = Node (mapTree f left) s (f a) (mapTree f right)
+
+
+
+
diff --git a/src/GF/Data/OrdSet.hs b/src/GF/Data/OrdSet.hs
new file mode 100644
index 000000000..84169a699
--- /dev/null
+++ b/src/GF/Data/OrdSet.hs
@@ -0,0 +1,111 @@
+
+
+--------------------------------------------------
+-- The class of ordered sets
+-- as described in section 2.2.1
+
+-- and an example implementation, 
+-- derived from the implementation in appendix A.1
+
+
+module OrdSet (OrdSet(..), Set) where
+
+import List (intersperse)
+
+
+--------------------------------------------------
+-- the class of ordered sets
+
+class OrdSet m where
+  emptySet  :: Ord a => m a
+  unitSet   :: Ord a => a -> m a
+  isEmpty   :: Ord a => m a -> Bool
+  elemSet   :: Ord a => a -> m a -> Bool
+  (<++>)    :: Ord a => m a -> m a -> m a
+  (<\\>)    :: Ord a => m a -> m a -> m a
+  plusMinus :: Ord a => m a -> m a -> (m a, m a)
+  union     :: Ord a => [m a] -> m a
+  makeSet   :: Ord a => [a] -> m a
+  elems     :: Ord a => m a -> [a]
+  ordSet    :: Ord a => [a] -> m a
+  limit     :: Ord a => (a -> m a) -> m a -> m a
+
+  xs <++> ys      = fst (plusMinus xs ys)
+  xs <\\> ys      = snd (plusMinus xs ys)
+  plusMinus xs ys = (xs <++> ys, xs <\\> ys)
+
+  union []   = emptySet
+  union [xs] = xs
+  union xyss = union xss <++> union yss
+    where (xss, yss)       = split xyss
+	  split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys)
+	  split xs         = (xs, [])
+
+  makeSet xs = union (map unitSet xs)
+
+  limit more start = limit' (start, start)
+    where limit' (old, new)
+	      | isEmpty new' = old
+	      | otherwise    = limit' (plusMinus new' old)
+	    where new'       = union (map more (elems new))
+
+
+--------------------------------------------------
+-- sets as ordered lists, 
+-- paired with a binary tree
+
+data Set a = Set [a] (TreeSet a)
+
+instance Eq a => Eq (Set a) where
+  Set xs _ == Set ys _ = xs == ys
+
+instance Ord a => Ord (Set a) where
+  compare (Set xs _) (Set ys _) = compare xs ys
+
+instance Show a => Show (Set a) where
+  show (Set xs _) = "{" ++ concat (intersperse "," (map show xs)) ++ "}"
+
+instance OrdSet Set where
+  emptySet  = Set []  (makeTree [])
+  unitSet a = Set [a] (makeTree [a])
+
+  isEmpty   (Set xs _) = null xs
+  elemSet a (Set _ xt) = elemTree a xt
+
+  plusMinus (Set xs _) (Set ys _) = (Set ps (makeTree ps), Set ms (makeTree ms))
+    where (ps, ms) = plm xs ys
+	  plm [] ys = (ys, [])
+	  plm xs [] = (xs, xs)
+	  plm xs@(x:xs') ys@(y:ys') = case compare x y of
+				        LT -> let (ps, ms) = plm xs' ys  in (x:ps, x:ms)
+					GT -> let (ps, ms) = plm xs  ys' in (y:ps,   ms)
+					EQ -> let (ps, ms) = plm xs' ys' in (x:ps,   ms)
+
+  elems (Set xs _) = xs
+  ordSet xs        = Set xs (makeTree xs)
+
+
+--------------------------------------------------
+-- binary search trees
+-- for logarithmic lookup time
+
+data TreeSet a = Nil | Node (TreeSet a) a (TreeSet a)
+
+makeTree xs = tree
+  where (tree,[])       = sl2bst (length xs) xs
+	sl2bst 0 xs     = (Nil, xs)
+	sl2bst 1 (a:xs) = (Node Nil a Nil, xs)
+	sl2bst n xs     = (Node ltree a rtree, zs)
+          where llen    = (n-1) `div` 2
+                rlen    = n - 1 - llen
+                (ltree, a:ys) = sl2bst llen xs
+                (rtree, zs)   = sl2bst rlen ys
+
+elemTree a Nil = False
+elemTree a (Node ltree x rtree) 
+    = case compare a x of
+        LT -> elemTree a ltree 
+        GT -> elemTree a rtree 
+        EQ -> True
+
+
diff --git a/src/GF/Data/Parsers.hs b/src/GF/Data/Parsers.hs
new file mode 100644
index 000000000..165d0f4e7
--- /dev/null
+++ b/src/GF/Data/Parsers.hs
@@ -0,0 +1,143 @@
+module Parsers where
+
+import Operations
+import Char
+
+
+infixr 2 |||, +||
+infixr 3 ***
+infixr 5 .>.
+infixr 5 ...
+infixr 5 ....
+infixr 5 +..
+infixr 5 ..+
+infixr 6 |>
+infixr 3 <<<
+
+-- some parser combinators a` la Wadler and Hutton
+-- no longer used in many places in GF
+
+type Parser a b = [a] -> [(b,[a])]
+
+parseResults :: Parser a b -> [a] -> [b]
+parseResults p s = [x | (x,r) <- p s, null r]
+
+parseResultErr :: Parser a b -> [a] -> Err b
+parseResultErr p s = case parseResults p s of
+  [x] -> return x
+  []  -> Bad "no parse"
+  _   -> Bad "ambiguous"
+
+(...) :: Parser a b -> Parser a c -> Parser a (b,c)
+(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t]
+
+(.>.) :: Parser a b -> (b -> Parser a c) -> Parser a c
+(p .>. f) s = [(c,r) | (x,t) <- p s, (c,r) <- f x t]
+
+(|||) :: Parser a b -> Parser a b -> Parser a b
+(p ||| q) s = p s ++ q s
+
+(+||) :: Parser a b -> Parser a b -> Parser a b
+p1 +|| p2 = take 1 . (p1 ||| p2)
+
+literal :: (Eq a) => a -> Parser a a
+literal x (c:cs) = [(x,cs) | x == c]
+literal _ _ = []
+
+(***) :: Parser a b -> (b -> c) -> Parser a c
+(p *** f) s = [(f x,r) | (x,r) <- p s] 
+
+succeed :: b -> Parser a b
+succeed v s = [(v,s)]
+
+fails :: Parser a b
+fails s = []
+
+(+..) :: Parser a b -> Parser a c -> Parser a c
+p1 +.. p2 = p1 ... p2 *** snd
+
+(..+) :: Parser a b -> Parser a c -> Parser a b
+p1 ..+ p2 = p1 ... p2 *** fst
+
+(<<<) :: Parser a b -> c -> Parser a c  -- return
+p <<< v = p *** (\x -> v)
+
+(|>) :: Parser a b -> (b -> Bool) -> Parser a b
+p |> b = p .>. (\x -> if b x then succeed x else fails)
+
+many :: Parser a b -> Parser a [b]
+many p = (p ... many p *** uncurry (:)) +|| succeed []
+
+some :: Parser a b -> Parser a [b]
+some p = (p ... many p) *** uncurry (:)
+
+longestOfMany :: Parser a b -> Parser a [b]
+longestOfMany p = p .>. (\x -> longestOfMany p *** (x:)) +|| succeed []
+
+closure :: (b -> Parser a b) -> (b -> Parser a b)
+closure p v = p v .>. closure p ||| succeed v
+
+pJunk   :: Parser Char String
+pJunk = longestOfMany (satisfy (\x -> elem x "\n\t "))
+
+pJ :: Parser Char a -> Parser Char a
+pJ p = pJunk +.. p ..+ pJunk
+
+pTList  :: String -> Parser Char a -> Parser Char [a]
+pTList t p = p .... many (jL t +.. p) *** (\ (x,y) -> x:y) -- mod. AR 5/1/1999
+
+pTJList  :: String -> String -> Parser Char a -> Parser Char [a]
+pTJList t1 t2 p = p .... many (literals t1 +.. jL t2 +.. p) *** (uncurry (:))
+
+pElem   :: [String] -> Parser Char String
+pElem l = foldr (+||) fails (map literals l)
+
+(....) :: Parser Char b -> Parser Char c -> Parser Char (b,c)
+p1 .... p2 = p1 ... pJunk +.. p2
+
+item :: Parser a a
+item (c:cs) = [(c,cs)]
+item [] = []
+
+satisfy :: (a -> Bool) -> Parser a a
+satisfy b = item |> b
+
+literals :: (Eq a,Show a) => [a] -> Parser a [a]
+literals l = case l of 
+  []  -> succeed [] 
+  a:l -> literal a ... literals l *** (\ (x,y) -> x:y)
+
+lits :: (Eq a,Show a) => [a] -> Parser a [a]
+lits ts = literals ts
+
+jL :: String -> Parser Char String
+jL = pJ . lits
+
+pParenth p = literal '(' +.. pJunk +.. p ..+ pJunk ..+ literal ')'
+pCommaList p = pTList "," (pJ p)                      -- p,...,p
+pOptCommaList p = pCommaList p ||| succeed []            -- the same or nothing
+pArgList p = pParenth (pCommaList p) ||| succeed [] -- (p,...,p), poss. empty
+pArgList2 p = pParenth (p ... jL "," +.. pCommaList p) *** uncurry (:) -- min.2 args
+
+longestOfSome p = (p ... longestOfMany p) *** (\ (x,y) -> x:y)
+
+pIdent = pLetter ... longestOfMany pAlphaPlusChar *** uncurry (:)
+  where alphaPlusChar c = isAlphaNum c || c=='_' || c=='\''
+
+pLetter = satisfy (`elem` (['A'..'Z'] ++ ['a'..'z'] ++ 
+                           ['À' .. 'Û'] ++ ['à' .. 'û'])) -- no such in Char
+pDigit         = satisfy isDigit
+pLetters       = longestOfSome pLetter
+pAlphanum      = pDigit ||| pLetter
+pAlphaPlusChar = pAlphanum ||| satisfy (`elem` "_'")
+
+pQuotedString = literal '"' +.. pEndQuoted where
+ pEndQuoted =
+       literal '"' *** (const [])
+   +|| (literal '\\' +.. item .>. \ c -> pEndQuoted *** (c:))
+   +|| item .>. \ c -> pEndQuoted *** (c:)
+
+pIntc :: Parser Char Int
+pIntc = some (satisfy numb) *** read
+         where numb x = elem x ['0'..'9']
+
diff --git a/src/GF/Data/Str.hs b/src/GF/Data/Str.hs
new file mode 100644
index 000000000..743bd71b8
--- /dev/null
+++ b/src/GF/Data/Str.hs
@@ -0,0 +1,106 @@
+module Str (
+  Str (..), Tok (..),        --- constructors needed in PrGrammar 
+  str2strings, str2allStrings, str, sstr, sstrV, 
+  isZeroTok, prStr, plusStr, glueStr,
+  strTok, 
+  allItems
+) where
+
+import Operations
+import 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)
+
+data Tok = 
+   TK String
+ | TN Ss [(Ss, [String])] -- variants depending on next string 
+    deriving (Eq, Ord, Show, Read)
+
+-- 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
+
+-- 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 t)) as] ++ [s])
+
+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
+    []            -> []
+
+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 = 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/Zipper.hs b/src/GF/Data/Zipper.hs
new file mode 100644
index 000000000..d498c5a56
--- /dev/null
+++ b/src/GF/Data/Zipper.hs
@@ -0,0 +1,172 @@
+module Zipper where
+
+import Operations
+
+-- Gérard Huet's zipper (JFP 7 (1997)). AR 10/8/2001
+
+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,[])
+
+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 (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 t = Loc (t,Top)
+
+goRoot = tree2loc . loc2tree
+
+goLast :: Loc a -> Err (Loc a)
+goLast = rep goAhead where
+  rep f s = err (const (return s)) (rep f) (f s)
+
+-- 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)