summaryrefslogtreecommitdiff
path: root/src/GF/Compile
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Compile')
-rw-r--r--src/GF/Compile/CheckGrammar.hs6
-rw-r--r--src/GF/Compile/Extend.hs10
-rw-r--r--src/GF/Compile/GrammarToCanon.hs6
-rw-r--r--src/GF/Compile/MkResource.hs13
-rw-r--r--src/GF/Compile/Optimize.hs8
-rw-r--r--src/GF/Compile/Rebuild.hs12
-rw-r--r--src/GF/Compile/Rename.hs12
-rw-r--r--src/GF/Compile/Update.hs21
8 files changed, 49 insertions, 39 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 12:27:09 +0000