BinTree vs. FiniteMap

src/GF/Canon/GetGFC.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/27 21:05:17 $ 
+-- > CVS $Date: 2005/05/30 18:39:43 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.8 $
+-- > CVS $Revision: 1.9 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
@@ -34,11 +34,13 @@ getCanonModule file = do
     _ -> ioeErr $ Bad "expected exactly one module in a file"
 
 getCanonGrammar :: FilePath -> IOE CanonGrammar
+-- getCanonGrammar = getCanonGrammarByLine
 getCanonGrammar file = do
   s <- ioeIO $ readFileIf file
   c <- ioeErr $ pCanon $ myLexer s
   return $ canon2grammar c
 
+{-
 -- the following surprisingly does not save memory so it is
 -- not in use
 
@@ -74,3 +76,4 @@ getCanonGrammarByLine file = do
 
       isHash a b = a `div` step < b `div` step
       step = size `div` 50
+-}

src/GF/Canon/MkGFC.hs

@@ -5,15 +5,15 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/27 21:05:17 $ 
+-- > CVS $Date: 2005/05/30 18:39:43 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.13 $
+-- > CVS $Revision: 1.14 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
 
 module GF.Canon.MkGFC (prCanonModInfo, prCanon, prCanonMGr,
-	      canon2grammar, grammar2canon, buildCanonGrammar,
+	      canon2grammar, grammar2canon, -- buildCanonGrammar,
 	      info2mod,
 	      trExp, rtExp, rtQIdent) where
 
@@ -173,6 +173,7 @@ rtIdent x
   | isWildIdent x = identC "h_" --- needed in declarations
   | otherwise = identC $ prt x ---
 
+{-
 -- the following is called in GetGFC to read gfc files line
 -- by line. It does not save memory, though, and is therefore
 -- not used.
@@ -184,7 +185,7 @@ buildCanonGrammar n gr0 line = mgr $ case line of
   LFlag f@(Flg (IC "modulesize") (IC n)) -> initModule f $ read $ tail n
   LFlag flag        -> newFlag flag
   LDef def          -> newDef $ def2info def
-  LEnd              -> cleanNames
+--  LEnd              -> cleanNames
   _                 -> M.modules gr0
  where
    newModule mt ext op = mod2info (Mod mt ext op [] []) : mods
@@ -198,10 +199,11 @@ buildCanonGrammar n gr0 line = mgr $ case line of
      (name, M.ModMod (M.Module mt com flags ee oo defs)) ->
        (name, M.ModMod (M.Module mt com flags ee oo 
           (upd (padd 8 n) d defs))) : tmods
-   cleanNames = case actm of
+
-     (name, M.ModMod (M.Module mt com flags ee oo defs)) ->
+--   cleanNames = case actm of
-       (name, M.ModMod (M.Module mt com (reverse flags) ee oo 
+--     (name, M.ModMod (M.Module mt com flags ee oo defs)) ->
-          (mapTree (\ (IC f,t) -> (IC (drop 8 f),t)) defs))) : tmods
+--       (name, M.ModMod (M.Module mt com (reverse flags) ee oo 
+--          (mapTree (\ (IC f,t) -> (IC (drop 8 f),t)) defs))) : tmods
 
    actm = head mods -- only used when a new mod has been created
    mods = M.modules gr0
@@ -214,16 +216,20 @@ buildCanonGrammar n gr0 line = mgr $ case line of
      )
 
    -- create an initial tree with who-cares value
-   newtree (i :: Int) = sorted2tree [
+   newtree (i :: Int) = emptyBinTree
-     (padd 8 k, ResPar []) | 
+--   newtree (i :: Int) = sorted2tree [
-     k <- [1..i]] --- padd (length (show i))
+--     (padd 8 k, ResPar []) | 
+--     k <- [1..i]] --- padd (length (show i))
 
-   padd l k = let sk = show k in identC (replicate (l - length sk) '0' ++ sk)
+   padd l k = 0
+--   padd l k = let sk = show k in identC (replicate (l - length sk) '0' ++ sk)
 
-   upd n d@(f,t) defs = case defs of
+   upd _ d defs = updateTree d defs
-     NT -> BT (merg n f,t) NT NT --- should not happen
+--   upd n d@(f,t) defs = case defs of
-     BT c@(a,_) left right 
+--     NT -> BT (merg n f,t) NT NT --- should not happen
-       | n < a  -> let left'  = upd n d left  in BT c left' right 
+--     BT c@(a,_) left right 
-       | n > a  -> let right' = upd n d right in BT c left right' 
+--       | n < a  -> let left'  = upd n d left  in BT c left' right 
-       | otherwise -> BT (merg n f,t) left right
+--       | n > a  -> let right' = upd n d right in BT c left right' 
-   merg (IC n) (IC f) = IC (n ++ f)
+--       | otherwise -> BT (merg n f,t) left right
+--   merg (IC n) (IC f) = IC (n ++ f)
+-}

src/GF/Compile/CheckGrammar.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/09 09:45:23 $ 
+-- > CVS $Date: 2005/05/30 18:39:43 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.26 $
+-- > CVS $Revision: 1.27 $
 --
 -- AR 4\/12\/1999 -- 1\/4\/2000 -- 8\/9\/2001 -- 15\/5\/2002 -- 27\/11\/2002 -- 18\/6\/2003
 --
@@ -118,7 +118,7 @@ checkAbsInfo st m (c,info) = do
      _ -> composOp (compAbsTyp g) t
 
 
-checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree (Ident,Info))
+checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info)
 checkCompleteGrammar abs cnc = do
   let js = jments cnc
   let fs = tree2list $ jments abs

src/GF/Compile/Extend.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:21:36 $ 
+-- > CVS $Date: 2005/05/30 18:39:43 $ 
--- > CVS $Author: bringert $
+-- > CVS $Author: aarne $
--- > CVS $Revision: 1.16 $
+-- > CVS $Revision: 1.17 $
 --
 -- AR 14\/5\/2003 -- 11\/11
 --
@@ -60,8 +60,8 @@ extendModule ms (name,mod) = case mod of
 -- | When extending a complete module: new information is inserted,
 -- and the process is interrupted if unification fails.
 -- If the extended module is incomplete, its judgements are just copied.
-extendMod :: Bool -> Ident -> Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) -> 
+extendMod :: Bool -> Ident -> Ident -> BinTree Ident Info -> BinTree Ident Info -> 
-             Err (BinTree (Ident,Info))
+             Err (BinTree Ident Info)
 extendMod isCompl name base old new = foldM try new $ tree2list old where
   try t i@(c,_) = errIn ("constant" +++ prt c) $
                   tryInsert (extendAnyInfo isCompl name base) indirIf t i

src/GF/Compile/GrammarToCanon.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/27 21:05:17 $ 
+-- > CVS $Date: 2005/05/30 18:39:43 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.18 $
+-- > CVS $Revision: 1.19 $
 --
 -- Code generator from optimized GF source code to GFC.
 -----------------------------------------------------------------------------
@@ -65,7 +65,7 @@ redModInfo (c,info) = do
          MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed
 
       --- this generates empty GFC reosurce for interface and incomplete
-      let js = if isIncompl then NT else jments m
+      let js = if isIncompl then emptyBinTree else jments m
           mt = mt0 ---- if isIncompl then MTResource else mt0
 
       defss <- mapM (redInfo a) $ tree2list $ js

src/GF/Compile/MkResource.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:21:38 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
--- > CVS $Author: bringert $
+-- > CVS $Author: aarne $
--- > CVS $Revision: 1.12 $
+-- > CVS $Revision: 1.13 $
 --
 -- Compile a gfc module into a "reuse" gfr resource, interface, or instance.
 -----------------------------------------------------------------------------
@@ -46,7 +46,8 @@ makeReuse gr r me mrc = do
       (ops,jms) <- case mc of 
         ModMod m -> case mtype m of
           MTAbstract -> liftM ((,) (opens m)) $ 
-                          mkResDefs True False gr r c me (extends m) (jments m) NT
+                          mkResDefs True False gr r c me 
+                            (extends m) (jments m) emptyBinTree
           _ -> prtBad "expected abstract to be the type of" c
         _ -> prtBad "expected abstract to be the type of" c
 
@@ -73,8 +74,8 @@ makeReuse gr r me mrc = do
 -- the second Boolean indicates if the definition needs be given
 mkResDefs :: Bool -> Bool -> 
              SourceGrammar -> Ident -> Ident -> [Ident] -> [Ident] -> 
-             BinTree (Ident,Info) -> BinTree (Ident,Info) -> 
+             BinTree Ident Info -> BinTree Ident Info -> 
-             Err (BinTree (Ident,Info))
+             Err (BinTree Ident Info)
 mkResDefs hasT isC gr r a mext maext abs cnc = mapMTree (mkOne a maext) abs where
 
   ifTyped  = yes --- if hasT then yes else const nope --- needed for TC

src/GF/Compile/Optimize.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:21:42 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
--- > CVS $Author: bringert $
+-- > CVS $Author: aarne $
--- > CVS $Revision: 1.14 $
+-- > CVS $Revision: 1.15 $
 --
 -- Top-level partial evaluation for GF source modules.
 -----------------------------------------------------------------------------
@@ -157,7 +157,7 @@ recordExpand typ trm = case unComputed typ of
 
 
 -- | auxiliaries for compiling the resource
-allOperDependencies :: Ident -> BinTree (Ident,Info) -> [(Ident,[Ident])]
+allOperDependencies :: Ident -> BinTree Ident Info -> [(Ident,[Ident])]
 allOperDependencies m b = 
   [(f, nub (opty pty ++ opty pt)) | (f, ResOper pty pt) <- tree2list b]
   where

src/GF/Compile/Rebuild.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:21:44 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
--- > CVS $Author: bringert $
+-- > CVS $Author: aarne $
--- > CVS $Revision: 1.12 $
+-- > CVS $Revision: 1.13 $
 --
 -- Rebuild a source module from incomplete and its with-instance.
 -----------------------------------------------------------------------------
@@ -51,8 +51,8 @@ rebuildModule ms mo@(i,mi) = do
               [] -> return $ replaceJudgements m js'
               j0:jj -> do 
                 m0 <- lookupModMod gr j0
-                let notInM0 c = not $ isInBinTree (fst c) $ mapTree fst $ jments m0
+                let notInM0 c _  = not $ isInBinTree c $ jments m0
-                let js2 = sorted2tree $ filter notInM0 $ tree2list js'
+                let js2 = filterBinTree notInM0 js'
                 if null jj 
                   then return $ replaceJudgements m js2
                   else Bad "FIXME: handle multiple inheritance in instance"
@@ -84,7 +84,7 @@ checkCompleteInstance abs cnc = ifNull (return ()) (Bad . unlines) $
   checkComplete [f | (f, ResOper (Yes _) _) <- abs'] cnc'
    where
      abs' = tree2list $ jments abs
-     cnc' = mapTree fst $ jments cnc
+     cnc' = jments cnc
      checkComplete sought given = foldr ckOne [] sought
        where
          ckOne f = if isInBinTree f given 

src/GF/Compile/Rename.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:21:46 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
--- > CVS $Author: bringert $
+-- > CVS $Author: aarne $
--- > CVS $Revision: 1.18 $
+-- > CVS $Revision: 1.19 $
 --
 -- AR 14\/5\/2003
 -- The top-level function 'renameGrammar' does several things:
@@ -61,7 +61,7 @@ renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod o
 
 type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])
 
-type StatusTree = BinTree (Ident,StatusInfo)
+type StatusTree = BinTree Ident StatusInfo
 
 type StatusInfo = Ident -> Term
 
@@ -114,7 +114,7 @@ info2status mq (c,i) = (c, case i of
   _           -> maybe Cn  Q mq
   )
 
-tree2status :: OpenSpec Ident -> BinTree (Ident,Info) -> BinTree (Ident,StatusInfo)
+tree2status :: OpenSpec Ident -> BinTree Ident Info -> BinTree Ident StatusInfo
 tree2status o = case o of
   OSimple _ i   -> mapTree (info2status (Just i))
   OQualif _ i j -> mapTree (info2status (Just j))
@@ -127,7 +127,7 @@ buildStatus gr c mo = let mo' = self2status c mo in case mo of
     mods <- mapM (lookupModule gr1 . openedModule) ops
     let sts = map modInfo2status $ zip ops mods    
     return $ if isModCnc m
-      then (NT, reverse sts) -- the module itself does not define any names
+      then (emptyBinTree, reverse sts) -- the module itself does not define any names
       else (mo',reverse sts) -- so the empty ident is not needed
 
 modInfo2status :: (OpenSpec Ident,SourceModInfo) -> (OpenSpec Ident, StatusTree)

src/GF/Compile/Update.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:21:48 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
--- > CVS $Author: bringert $
+-- > CVS $Author: aarne $
--- > CVS $Revision: 1.7 $
+-- > CVS $Revision: 1.8 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
@@ -39,7 +39,7 @@ updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where
        _ -> (n,mod) --- no error msg
 
 -- | combine a list of definitions into a balanced binary search tree
-buildAnyTree :: [(Ident,Info)] -> Err (BinTree (Ident, Info))
+buildAnyTree :: [(Ident,Info)] -> Err (BinTree Ident Info)
 buildAnyTree ias = do
   ias' <- combineAnyInfos ias
   return $ buildTree ias'
@@ -94,9 +94,17 @@ unifyInfos unif ris = do
   info <- foldM (unif c) i is
   return (c,info)
 
+
 tryInsert :: Ord a => (b -> b -> Err b) -> (b -> b) ->
-             BinTree (a,b) -> (a,b) -> Err (BinTree (a,b))
+             BinTree a b -> (a,b) -> Err (BinTree a b)
-tryInsert unif indir tree z@(x, info) = case tree of
+tryInsert unif indir tree z@(x, info) = case justLookupTree x tree of
+  Ok info0 -> do
+    info1 <- unif info info0
+    return $ updateTree (x,info1) tree 
+  _ -> return $ updateTree (x,indir info) tree
+
+{- ----
+case tree of
  NT -> return $ BT (x, indir info) NT NT
  BT c@(a,info0) left right 
    | x < a  -> do
@@ -108,6 +116,7 @@ tryInsert unif indir tree z@(x, info) = case tree of
    | x == a -> do
        info' <- unif info info0
        return $ BT (x,info') left right
+-}
 
 --- addToMaybeList m c = maybe (return c) (\old -> return (c ++ old)) m
 

src/GF/Data/Operations.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:22:05 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
--- > CVS $Author: bringert $
+-- > CVS $Author: aarne $
--- > CVS $Revision: 1.19 $
+-- > CVS $Revision: 1.20 $
 --
 -- some auxiliary GF operations. AR 19\/6\/1998 -- 6\/2\/2001
 --
@@ -32,12 +32,12 @@ module GF.Data.Operations (-- * misc functions
 		   mapP,
 		   unifPerhaps, updatePerhaps, updatePerhapsHard,
 
-		   -- * binary search trees
+		   -- * binary search trees; now with FiniteMap
-		   BinTree(..), isInBinTree, commonsInTree, justLookupTree,
+		   BinTree, emptyBinTree, isInBinTree, justLookupTree,
-		   lookupTree, lookupTreeEq, lookupTreeMany, updateTree,
+		   lookupTree, lookupTreeMany, updateTree,
-		   updateTreeGen, updateTreeEq, updatesTree, updatesTreeNondestr, buildTree,
+		   buildTree, filterBinTree,
 		   sorted2tree, mapTree, mapMTree, tree2list,
-		   depthTree, mergeTrees, 
+ 
 
 		   -- * parsing
 		   WParser, wParseResults, paragraphs,
@@ -77,7 +77,8 @@ module GF.Data.Operations (-- * misc functions
 
 import Data.Char (isSpace, toUpper, isSpace, isDigit)
 import Data.List (nub, sortBy, sort, deleteBy, nubBy)
-import Control.Monad (liftM2, MonadPlus, mzero, mplus)
+--import Data.FiniteMap
+import Control.Monad (liftM,liftM2, MonadPlus, mzero, mplus)
 
 infixr 5 +++
 infixr 5 ++-
@@ -288,59 +289,46 @@ updatePerhapsHard old p1 p2 = case (p1,p2) of
   _ -> unifPerhaps p1 p2
 
 -- binary search trees
+--- FiniteMap implementation is slower in crucial tests
 
-data BinTree a = NT | BT a !(BinTree a) !(BinTree a) deriving (Show,Read)
+data BinTree a b = NT | BT (a,b) !(BinTree a b) !(BinTree a b) deriving (Show)
+-- type BinTree a b = FiniteMap a b
 
-isInBinTree :: (Ord a) => a -> BinTree a -> Bool
+emptyBinTree :: BinTree a b
-isInBinTree x tree = case tree of
+emptyBinTree = NT
- NT -> False
+-- emptyBinTree = emptyFM
- 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
+isInBinTree :: (Ord a) => a -> BinTree a b -> Bool
---
+isInBinTree x = err (const False) (const True) .  justLookupTree x
--- the complexity is O(log |old|, |new|) so the heuristic is that new is smaller
+-- isInBinTree = elemFM
-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 :: (Ord a) => a -> BinTree a b -> Err b
 justLookupTree = lookupTree (const [])
 
-lookupTree :: (Ord a) => (a -> String) -> a -> BinTree (a,b) -> Err b
+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
+--lookupTree pr x tree = case lookupFM tree x of
+--  Just y -> return y
+--  _ -> Bad ("no occurrence of element" +++ pr x)
 
-lookupTreeEq :: (Ord a) => 
+lookupTreeMany :: Ord a => (a -> String) -> [BinTree a b] -> a -> Err b
-     (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 :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b
+-- updateTree (a,b) tr = addToFM tr a b
 updateTree = updateTreeGen True
 
 -- | destructive or not
-updateTreeGen :: (Ord a) => Bool -> (a,b) -> BinTree (a,b) -> BinTree (a,b)
+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 
@@ -350,67 +338,44 @@ updateTreeGen destr z@(x,y) tree = case tree of
                     then BT z left right -- removing the old value of a
                     else tree            -- retaining the old value if one exists
 
-updateTreeEq :: 
+buildTree :: (Ord a) => [(a,b)] -> BinTree a b
-  (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
+-- buildTree = listToFM
 
-sorted2tree :: [(a,b)] -> BinTree (a,b)
+sorted2tree :: Ord a => [(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
+--sorted2tree = listToFM
 
-mapTree :: (a -> b) -> BinTree a -> BinTree b
+--- dm less general than orig
+mapTree :: ((a,b) -> (a,c)) -> BinTree a b -> BinTree a c
 mapTree f NT = NT
 mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right)
+--mapTree f = mapFM (\k v -> snd (f (k,v)))
 
-mapMTree :: Monad m => (a -> m b) -> BinTree a -> m (BinTree b)
+--- fm less efficient than orig?
+mapMTree :: (Ord a,Monad m) => ((a,b) -> m (a,c)) -> BinTree a b -> m (BinTree a c)
 mapMTree f NT = return NT
 mapMTree f (BT a left right) = do
- a'     <- f a
+  a'     <- f a
- left'  <- mapMTree f left 
+  left'  <- mapMTree f left 
- right' <- mapMTree f right
+  right' <- mapMTree f right
- return $ BT a' left' right'
+  return $ BT a' left' right'
+--mapMTree f t = liftM listToFM $ mapM f $ fmToList t
 
-tree2list :: BinTree a -> [a] -- inorder
+filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b
+-- filterFM f t
+filterBinTree f = sorted2tree . filter (uncurry f) . tree2list
+
+tree2list :: BinTree a b -> [(a,b)] -- inorder
 tree2list NT = []
 tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right
-
+--tree2list = fmToList
-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
 

src/GF/Grammar/PrGrammar.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/28 16:42:49 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.14 $
+-- > CVS $Revision: 1.15 $
 --
 -- AR 7\/12\/1999 - 1\/4\/2000 - 10\/5\/2003
 --
@@ -270,7 +270,7 @@ prOperSignature (f, t) = prQIdent f +++ ":" +++ prt t
 
 -- to look up a constant etc in a search tree
 
-lookupIdent :: Ident -> BinTree (Ident,b) -> Err b
+lookupIdent :: Ident -> BinTree Ident b -> Err b
 lookupIdent c t = case lookupTree prt c t of
   Ok v -> return v
   _ -> prtBad "unknown identifier" c

src/GF/Infra/Modules.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/14 08:38:55 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.22 $
+-- > CVS $Revision: 1.23 $
 --
 -- Datastructures and functions for modules, common to GF and GFC.
 --
@@ -61,11 +61,13 @@ data Module i f a = Module {
     mtype   :: ModuleType i ,
     mstatus :: ModuleStatus ,
     flags   :: [f] ,
-    extends :: [i],
+    extends :: [i], ---- [(i,MInclude i)],
     opens   :: [OpenSpec i] ,
-    jments  :: BinTree (i,a)
+    jments  :: BinTree i a
   }
-  deriving Show
+---  deriving Show
+instance Show (Module i f a) where
+  show _ = "cannot show Module with FiniteMap"
 
 -- | encoding the type of the module
 data ModuleType i = 
@@ -83,6 +85,9 @@ data ModuleType i =
 data MReuseType i = MRInterface i | MRInstance i i | MRResource i
   deriving (Show,Eq)
 
+data MInclude i = MIAll | MIOnly [i] | MIExcept [i]
+  deriving (Show,Eq)
+
 -- | previously: single inheritance
 extendm :: Module i f a -> Maybe i
 extendm m = case extends m of
@@ -103,7 +108,7 @@ updateModule :: Ord i => Module i f t -> i -> t -> Module i f t
 updateModule (Module  mt ms fs me ops js) i t = 
   Module mt ms fs me ops (updateTree (i,t) js)
 
-replaceJudgements :: Module i f t -> BinTree (i,t) -> Module i f t
+replaceJudgements :: Module i f t -> BinTree i t -> Module i f t
 replaceJudgements (Module mt ms fs me ops _) js = Module mt ms fs me ops js
 
 addOpenQualif :: i -> i -> Module i f t -> Module i f t
@@ -240,7 +245,7 @@ emptyModInfo :: ModInfo i f a
 emptyModInfo = ModMod emptyModule
 
 emptyModule :: Module i f a
-emptyModule = Module MTResource MSComplete [] [] [] NT
+emptyModule = Module MTResource MSComplete [] [] [] emptyBinTree
 
 -- | we store the module type with the identifier
 data IdentM i = IdentM {

src/GF/Source/SourceToGrammar.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/26 14:18:18 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.24 $
+-- > CVS $Revision: 1.25 $
 --
 -- based on the skeleton Haskell module generated by the BNF converter
 -----------------------------------------------------------------------------
@@ -101,11 +101,11 @@ transModDef x = case x of
         flags'   <- return       [f | Right fs <- defs0, f <- fs]
         return (id',GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs'))
       MReuse _ -> do
-        return (id', GM.ModMod (GM.Module mtyp' mstat' [] [] [] NT))
+        return (id', GM.ModMod (GM.Module mtyp' mstat' [] [] [] emptyBinTree))
       MUnion imps -> do
         imps' <- mapM transIncluded imps        
         return (id', 
-          GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' [] [] [] NT))
+          GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' [] [] [] emptyBinTree))
   
       MWith m opens -> do
         m'       <- transIdent m

src/GF/UseGrammar/Generate.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:23:46 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
--- > CVS $Author: bringert $
+-- > CVS $Author: aarne $
--- > CVS $Revision: 1.14 $
+-- > CVS $Revision: 1.15 $
 --
 -- Generate all trees of given category and depth. AR 30\/4\/2004
 --
@@ -101,7 +101,7 @@ generate gr ifm cat i mn mt = case mt of
   allTrees = genAll i
 
   -- dynamic generation
-  genAll :: Int -> BinTree (SCat,[[STree]])
+  genAll :: Int -> BinTree SCat [[STree]]
   genAll i = iter i genNext (mapTree (\ (c,_) -> (c,[[]])) gr)
 
   iter 0 f tr = tr
@@ -126,7 +126,7 @@ generate gr ifm cat i mn mt = case mt of
     SMeta k     -> gen k 
     _ -> [t]
 
-type SGrammar = BinTree (SCat,[SRule])
+type SGrammar = BinTree SCat [SRule]
 type SIdent = String
 type SRule = (SFun,SType)
 type SType = ([SCat],SCat)

src/GF/UseGrammar/Information.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:23:47 $ 
+-- > CVS $Date: 2005/05/30 18:39:45 $ 
--- > CVS $Author: bringert $
+-- > CVS $Author: aarne $
--- > CVS $Revision: 1.5 $
+-- > CVS $Revision: 1.6 $
 --
 -- information on module, category, function, operation, parameter,... 
 -- AR 16\/9\/2003.
@@ -135,7 +135,7 @@ getInformation opts st c = allChecks $ [
    cs  = [(i,m) | (i,ModMod m) <- modules can]
    cf  = concatMap ruleGroupsOfCF $ map snd $ cfs st
 
-ownConstants :: BinTree (Ident, Info) -> [Ident]
+ownConstants :: BinTree Ident Info -> [Ident]
 ownConstants = map fst . filter isOwn . tree2list where
   isOwn (c,i) = case i of
     AnyInd _ _ -> False