BinTree vs. FiniteMap

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 $Author: bringert $
--- > CVS $Revision: 1.16 $
+-- > CVS $Date: 2005/05/30 18:39:43 $ 
+-- > CVS $Author: aarne $
+-- > 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) -> 
-             Err (BinTree (Ident,Info))
+extendMod :: Bool -> Ident -> Ident -> BinTree Ident Info -> 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 $Author: bringert $
--- > CVS $Revision: 1.12 $
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Author: aarne $
+-- > 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) -> 
-             Err (BinTree (Ident,Info))
+             BinTree Ident Info -> 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 $Author: bringert $
--- > CVS $Revision: 1.14 $
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Author: aarne $
+-- > 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 $Author: bringert $
--- > CVS $Revision: 1.12 $
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Author: aarne $
+-- > 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 js2 = sorted2tree $ filter notInM0 $ tree2list js'
+                let notInM0 c _  = not $ isInBinTree c $ jments m0
+                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 $Author: bringert $
--- > CVS $Revision: 1.18 $
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Author: aarne $
+-- > 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 $Author: bringert $
--- > CVS $Revision: 1.7 $
+-- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Author: aarne $
+-- > 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))
-tryInsert unif indir tree z@(x, info) = case tree of
+             BinTree a b -> (a,b) -> Err (BinTree a b)
+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