GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

BinTree vs. FiniteMap

Browse Source
This commit is contained in:
aarne
2005-05-30 17:39:43 +00:00
parent 24d5b02523
commit 5bf9a7fe70
16 changed files with 155 additions and 166 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
src/GF/Canon/GetGFC.hs
View File

@@ -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
-}

44
src/GF/Canon/MkGFC.hs
View File

@@ -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)
-}

6
src/GF/Compile/CheckGrammar.hs
View File

@@ -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

10
src/GF/Compile/Extend.hs
View File

@@ -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

6
src/GF/Compile/GrammarToCanon.hs
View File

@@ -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

13
src/GF/Compile/MkResource.hs
View File

@@ -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

8
src/GF/Compile/Optimize.hs
View File

@@ -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

12
src/GF/Compile/Rebuild.hs
View File

@@ -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

12
src/GF/Compile/Rename.hs
View File

@@ -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)

21
src/GF/Compile/Update.hs
View File

@@ -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

131
src/GF/Data/Operations.hs
View File

@@ -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

6
src/GF/Grammar/PrGrammar.hs
View File

@@ -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

19
src/GF/Infra/Modules.hs
View File

@@ -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 {

8
src/GF/Source/SourceToGrammar.hs
View File

@@ -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

10
src/GF/UseGrammar/Generate.hs
View File

@@ -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)

8
src/GF/UseGrammar/Information.hs
View File

@@ -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