From 5bf9a7fe706e4e2d45f148dddf591c34ed1b72b3 Mon Sep 17 00:00:00 2001 From: aarne Date: Mon, 30 May 2005 17:39:43 +0000 Subject: [PATCH] BinTree vs. FiniteMap --- src/GF/Canon/GetGFC.hs | 7 +- src/GF/Canon/MkGFC.hs | 44 ++++++----- src/GF/Compile/CheckGrammar.hs | 6 +- src/GF/Compile/Extend.hs | 10 +-- src/GF/Compile/GrammarToCanon.hs | 6 +- src/GF/Compile/MkResource.hs | 13 +-- src/GF/Compile/Optimize.hs | 8 +- src/GF/Compile/Rebuild.hs | 12 +-- src/GF/Compile/Rename.hs | 12 +-- src/GF/Compile/Update.hs | 21 +++-- src/GF/Data/Operations.hs | 131 +++++++++++-------------------- src/GF/Grammar/PrGrammar.hs | 6 +- src/GF/Infra/Modules.hs | 19 +++-- src/GF/Source/SourceToGrammar.hs | 8 +- src/GF/UseGrammar/Generate.hs | 10 +-- src/GF/UseGrammar/Information.hs | 8 +- 16 files changed, 155 insertions(+), 166 deletions(-) diff --git a/src/GF/Canon/GetGFC.hs b/src/GF/Canon/GetGFC.hs index cc22e4bff..a61228cb9 100644 --- a/src/GF/Canon/GetGFC.hs +++ b/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 +-} diff --git a/src/GF/Canon/MkGFC.hs b/src/GF/Canon/MkGFC.hs index 0868a2642..d727edd08 100644 --- a/src/GF/Canon/MkGFC.hs +++ b/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)) -> - (name, M.ModMod (M.Module mt com (reverse flags) ee oo - (mapTree (\ (IC f,t) -> (IC (drop 8 f),t)) defs))) : tmods + +-- cleanNames = case actm of +-- (name, M.ModMod (M.Module mt com flags ee oo defs)) -> +-- (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 [ - (padd 8 k, ResPar []) | - k <- [1..i]] --- padd (length (show i)) + newtree (i :: Int) = emptyBinTree +-- newtree (i :: Int) = sorted2tree [ +-- (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 - NT -> BT (merg n f,t) NT NT --- should not happen - BT c@(a,_) left right - | n < a -> let left' = upd n d left in BT c left' right - | n > a -> let right' = upd n d right in BT c left right' - | otherwise -> BT (merg n f,t) left right - merg (IC n) (IC f) = IC (n ++ f) + upd _ d defs = updateTree d defs +-- upd n d@(f,t) defs = case defs of +-- NT -> BT (merg n f,t) NT NT --- should not happen +-- BT c@(a,_) left right +-- | n < a -> let left' = upd n d left in BT c left' right +-- | n > a -> let right' = upd n d right in BT c left right' +-- | otherwise -> BT (merg n f,t) left right +-- merg (IC n) (IC f) = IC (n ++ f) +-} diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index 05227f284..e8fa6303c 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/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 diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs index a412ab5c3..b519bf2fd 100644 --- a/src/GF/Compile/Extend.hs +++ b/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 diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs index 4a07de157..affdffb7e 100644 --- a/src/GF/Compile/GrammarToCanon.hs +++ b/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 diff --git a/src/GF/Compile/MkResource.hs b/src/GF/Compile/MkResource.hs index c33455e1a..3ba67d49e 100644 --- a/src/GF/Compile/MkResource.hs +++ b/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 diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs index 0dcb442ae..194bf27e4 100644 --- a/src/GF/Compile/Optimize.hs +++ b/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 diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs index 46230df7f..2e7bdd65d 100644 --- a/src/GF/Compile/Rebuild.hs +++ b/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 diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs index 94680a165..d38b897a7 100644 --- a/src/GF/Compile/Rename.hs +++ b/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) diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs index d031dbf5a..1570cbdaa 100644 --- a/src/GF/Compile/Update.hs +++ b/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 diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs index e20dc8086..c297bc55a 100644 --- a/src/GF/Data/Operations.hs +++ b/src/GF/Data/Operations.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/21 16:22:05 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.19 $ +-- > CVS $Date: 2005/05/30 18:39:44 $ +-- > CVS $Author: aarne $ +-- > 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 - BinTree(..), isInBinTree, commonsInTree, justLookupTree, - lookupTree, lookupTreeEq, lookupTreeMany, updateTree, - updateTreeGen, updateTreeEq, updatesTree, updatesTreeNondestr, buildTree, + -- * binary search trees; now with FiniteMap + BinTree, emptyBinTree, isInBinTree, justLookupTree, + lookupTree, lookupTreeMany, updateTree, + 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 -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 +emptyBinTree :: BinTree a b +emptyBinTree = NT +-- emptyBinTree = emptyFM --- | 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 +isInBinTree :: (Ord a) => a -> BinTree a b -> Bool +isInBinTree x = err (const False) (const True) . justLookupTree x +-- isInBinTree = elemFM -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) => - (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 :: 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 :: - (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 :: (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 - left' <- mapMTree f left - right' <- mapMTree f right - return $ BT a' left' right' + a' <- f a + left' <- mapMTree f left + right' <- mapMTree f 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 - -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 - +--tree2list = fmToList -- parsing diff --git a/src/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs index 3d1404660..a5471d6ea 100644 --- a/src/GF/Grammar/PrGrammar.hs +++ b/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 diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index 86a11b446..63f14d2f4 100644 --- a/src/GF/Infra/Modules.hs +++ b/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 { diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index 21e91d70a..2247bd8d7 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/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 diff --git a/src/GF/UseGrammar/Generate.hs b/src/GF/UseGrammar/Generate.hs index ee7419fb5..c19435410 100644 --- a/src/GF/UseGrammar/Generate.hs +++ b/src/GF/UseGrammar/Generate.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/21 16:23:46 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.14 $ +-- > CVS $Date: 2005/05/30 18:39:44 $ +-- > CVS $Author: aarne $ +-- > 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) diff --git a/src/GF/UseGrammar/Information.hs b/src/GF/UseGrammar/Information.hs index 37cacbb1a..446173aa2 100644 --- a/src/GF/UseGrammar/Information.hs +++ b/src/GF/UseGrammar/Information.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/21 16:23:47 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ +-- > CVS $Date: 2005/05/30 18:39:45 $ +-- > CVS $Author: aarne $ +-- > 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