summaryrefslogtreecommitdiff
path: root/src/GF/Compile
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Compile')
-rw-r--r--src/GF/Compile/Compile.hs29
-rw-r--r--src/GF/Compile/Extend.hs101
-rw-r--r--src/GF/Compile/GrammarToCanon.hs9
-rw-r--r--src/GF/Compile/Rebuild.hs40
-rw-r--r--src/GF/Compile/Rename.hs30
5 files changed, 107 insertions, 102 deletions
diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs
index edd75ef6b..cc327be37 100644
--- a/src/GF/Compile/Compile.hs
+++ b/src/GF/Compile/Compile.hs
@@ -13,6 +13,7 @@ import MkResource
-- the main compiler passes
import GetGrammar
+import Extend
import Rebuild
import Rename
import Refresh
@@ -93,7 +94,7 @@ reverseModules (MGrammar ms) = MGrammar $ reverse ms
keepResModules :: Options -> SourceGrammar -> SourceGrammar
keepResModules opts gr =
if oElem retainOpers opts
- then MGrammar $ reverse [(i,mi) | (i,mi) <- modules gr, isResourceModule mi]
+ then MGrammar $ reverse [(i,mi) | (i,mi@(ModMod m)) <- modules gr, isModRes m]
else emptyMGrammar
@@ -157,7 +158,8 @@ makeSourceModule opts env@(k,gr,can) mo@(i,mi) = case mi of
where
putp = putPointE opts
-compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
+compileSourceModule :: Options -> CompileEnv ->
+ SourceModule -> IOE (Int,SourceModule)
compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
let putp = putPointE opts
@@ -165,16 +167,25 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
mo1 <- ioeErr $ rebuildModule mos mo
- mo2:_ <- putp " renaming " $ ioeErr $ renameModule mos mo1
+ mo1b <- ioeErr $ extendModule mos mo1
+ ---- prDebug mo1b
- (mo3:_,warnings) <- putp " type checking" $ ioeErr $ showCheckModule mos mo2
- putStrE warnings
+ case mo1b of
+ (_,ModMod n) | not (isCompleteModule n) -> return (k,mo1b)
+ _ -> do
+ mo2:_ <- putp " renaming " $ ioeErr $ renameModule mos mo1b
+
+ (mo3:_,warnings) <- putp " type checking" $ ioeErr $ showCheckModule mos mo2
+ putStrE warnings
- (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3
+ (k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3
- mo4:_ <- putp " optimizing " $ ioeErr $ evalModule mos mo3r
+ mo4:_ <- putp " optimizing " $ ioeErr $ evalModule mos mo3r
+
+ return (k',mo4)
+ where
+ prDebug mo = ioeIO $ putStrLn $ prGrammar $ MGrammar [mo] ---- debug
- return (k',mo4)
generateModuleCode :: Options -> InitPath -> SourceModule -> IOE GFC.CanonModule
generateModuleCode opts path minfo@(name,info) = do
@@ -186,7 +197,7 @@ generateModuleCode opts path minfo@(name,info) = do
-- for resource, also emit gfr
case info of
- ModMod m | isResourceModule info && isCompilable info && emit && nomulti -> do
+ ModMod m | isModRes m && isCompilable info && emit && nomulti -> do
let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo]))
ioeIO $ writeFile file out >> putStr (" wrote file" +++ file)
_ -> return ()
diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs
index c0c46f956..689c59553 100644
--- a/src/GF/Compile/Extend.hs
+++ b/src/GF/Compile/Extend.hs
@@ -10,27 +10,56 @@ import Operations
import Monad
--- AR 14/5/2003
+-- AR 14/5/2003 -- 11/11
--- The top-level function $extendModInfo$
+-- The top-level function $extendModule$
-- extends a module symbol table by indirections to the module it extends
---- this is not in use 5/11/2003
-extendModInfo :: Ident -> SourceModInfo -> SourceModInfo -> Err SourceModInfo
-extendModInfo name old new = case (old,new) of
- (ModMod m0, ModMod (Module mt st fs _ ops js)) -> do
- testErr (mtype m0 == mt) ("illegal extension type at module" +++ show name)
- js' <- extendMod name (jments m0) js
- return $ ModMod (Module mt st fs Nothing ops js)
+extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
+extendModule ms (name,mod) = case mod of
+ ModMod (Module mt st fs me ops js) -> do
+
+{- --- building the {s : Str} lincat from js0
+ js <- case mt of
+ MTConcrete a -> do
+ ModMod ma <- lookupModule (MGrammar ms) a
+ let cats = [c | (c,AbsCat _ _) <- tree2list $ jments ma]
+ jscs = [(c,CncCat (yes defLinType) nope nope) | c <- cats]
+ return $ updatesTreeNondestr jscs js0
+ _ -> return js0
+-}
+
+ case me of
+ -- if the module is an extension of another one...
+ Just n -> do
+ (m0,isCompl) <- do
+ m <- lookupModMod (MGrammar ms) n
+
+ -- test that the module types match, and find out if the old is complete
+ testErr (sameMType (mtype m) mt)
+ ("illegal extension type to module" +++ prt name)
+ return (m,isCompleteModule m)
+
+ -- build extension in a way depending on whether the old module is complete
+ js1 <- extendMod isCompl n (jments m0) js
--- this is what happens when extending a module: new information is inserted,
--- and the process is interrupted if unification fails
+ -- if incomplete, throw away extension information
+ let me' = if isCompl then me else Nothing
+ return $ (name,ModMod (Module mt st fs me' ops js1))
-extendMod :: Ident -> BinTree (Ident,Info) -> BinTree (Ident,Info) ->
+ -- if the module is not an extension, just return it
+ _ -> return (name,mod)
+
+-- 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 -> BinTree (Ident,Info) -> BinTree (Ident,Info) ->
Err (BinTree (Ident,Info))
-extendMod name old new = foldM try new $ tree2list old where
+extendMod isCompl name old new = foldM try new $ tree2list old where
try t i@(c,_) = errIn ("constant" +++ prt c) $
- tryInsert (extendAnyInfo name) (indirInfo name) t i
+ tryInsert (extendAnyInfo isCompl name) indirIf t i
+ indirIf = if isCompl then indirInfo name else id
indirInfo :: Ident -> Info -> Info
indirInfo n info = AnyInd b n' where
@@ -41,46 +70,37 @@ indirInfo n info = AnyInd b n' where
AnyInd b k -> (b,k)
_ -> (False,n) ---- canonical in Abs
-{- ----
-case info of
- AbsFun pty ptr -> AbsFun (perhIndir n pty) (perhIndir n ptr)
- ---- find a suitable indirection for cat info!
-
- ResOper pty ptr -> ResOper (perhIndir n pty) (perhIndir n ptr)
- ResParam pp -> ResParam (perhIndir n pp)
- _ -> info
-
- CncCat pty ptr ppr -> CncCat (perhIndir n pty) (perhIndir n ptr) (perhIndir n ppr)
- CncFun m ptr ppr -> CncFun m (perhIndir n ptr) (perhIndir n ppr)
--}
-
perhIndir :: Ident -> Perh a -> Perh a
perhIndir n p = case p of
Yes _ -> May n
_ -> p
-extendAnyInfo :: Ident -> Info -> Info -> Err Info
-extendAnyInfo n i j = errIn ("building extension for" +++ prt n) $ case (i,j) of
+extendAnyInfo :: Bool -> Ident -> Info -> Info -> Err Info
+extendAnyInfo isc n i j = errIn ("building extension for" +++ prt n) $ case (i,j) of
(AbsCat mc1 mf1, AbsCat mc2 mf2) ->
- liftM2 AbsCat (updatePerhaps n mc1 mc2) (updatePerhaps n mf1 mf2) --- add cstrs
+ liftM2 AbsCat (updn mc1 mc2) (updn mf1 mf2) --- add cstrs
(AbsFun mt1 md1, AbsFun mt2 md2) ->
- liftM2 AbsFun (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2) --- add defs
-
- (ResParam mt1, ResParam mt2) -> liftM ResParam $ updatePerhaps n mt1 mt2
- (ResValue mt1, ResValue mt2) -> liftM ResValue $ updatePerhaps n mt1 mt2
- (ResOper mt1 m1, ResOper mt2 m2) -> extendResOper n mt1 m1 mt2 m2
-
+ liftM2 AbsFun (updn mt1 mt2) (updn md1 md2) --- add defs
+ (ResParam mt1, ResParam mt2) ->
+ liftM ResParam $ updn mt1 mt2
+ (ResValue mt1, ResValue mt2) ->
+ liftM ResValue $ updn mt1 mt2
+ (ResOper mt1 m1, ResOper mt2 m2) -> ---- extendResOper n mt1 m1 mt2 m2
+ liftM2 ResOper (updn mt1 mt2) (updn m1 m2)
(CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) ->
- liftM3 CncCat (updatePerhaps n mc1 mc2)
- (updatePerhaps n mf1 mf2) (updatePerhaps n mp1 mp2)
+ liftM3 CncCat (updn mc1 mc2) (updn mf1 mf2) (updn mp1 mp2)
(CncFun m mt1 md1, CncFun _ mt2 md2) ->
- liftM2 (CncFun m) (updatePerhaps n mt1 mt2) (updatePerhaps n md1 md2)
+ liftM2 (CncFun m) (updn mt1 mt2) (updn md1 md2)
- (AnyInd _ _, ResOper _ _) -> return j ----
+---- (AnyInd _ _, ResOper _ _) -> return j ----
_ -> Bad $ "cannot unify information in" ++++ show i ++++ "and" ++++ show j
+ where
+ updn = if isc then (updatePerhaps n) else (updatePerhapsHard n)
+
+{- ---- no more needed: this is done in Rebuild
-- opers declared in an interface and defined in an instance are a special case
extendResOper n mt1 m1 mt2 m2 = case (m1,m2) of
@@ -93,3 +113,4 @@ extendResOper n mt1 m1 mt2 m2 = case (m1,m2) of
Q _ c -> Vr c
QC _ c -> Vr c
_ -> composSafeOp strp t
+-}
diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs
index ab493f761..786eb5fa5 100644
--- a/src/GF/Compile/GrammarToCanon.hs
+++ b/src/GF/Compile/GrammarToCanon.hs
@@ -38,7 +38,8 @@ redModInfo (c,info) = do
c' <- redIdent c
info' <- case info of
ModMod m -> do
- (e,os) <- redExtOpen m
+ let isIncompl = mstatus m == MSIncomplete
+ (e,os) <- if isIncompl then return (Nothing,[]) else redExtOpen m ----
flags <- mapM redFlag $ flags m
(a,mt) <- case mtype m of
MTConcrete a -> do
@@ -51,7 +52,7 @@ redModInfo (c,info) = do
MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed
---- this generates empty GFC. Better: none
- let js = if mstatus m == MSIncomplete then NT else jments m
+ let js = if isIncompl then NT else jments m
defss <- mapM (redInfo a) $ tree2list $ js
defs <- return $ sorted2tree $ concat defss -- sorted, but reduced
@@ -62,7 +63,9 @@ redModInfo (c,info) = do
e' <- case extends m of
Just e -> liftM Just $ redIdent e
_ -> return Nothing
- os' <- mapM (\ (OQualif q _ i) -> liftM (OSimple q) (redIdent i)) $ opens m
+ os' <- mapM (\o -> case o of
+ OQualif q _ i -> liftM (OSimple q) (redIdent i)
+ _ -> prtBad "cannot translate unqualified open in" c) $ opens m
return (e',os')
om = oSimple . openedModule --- normalizing away qualif
diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs
index 5a551ea6c..d0e750e09 100644
--- a/src/GF/Compile/Rebuild.hs
+++ b/src/GF/Compile/Rebuild.hs
@@ -19,43 +19,38 @@ rebuildModule ms mo@(i,mi) = do
let gr = MGrammar ms
deps <- moduleDeps ms
is <- openInterfaces deps i
- mi' <- case mi of
+ mi' <- case mi of
- -- add the interface type signatures into an instance module
+ -- add the information given in interface into an instance module
ModMod m -> do
testErr (null is || mstatus m == MSIncomplete)
- ("module" +++ prt i +++ "must be declared incomplete")
- mi' <- case mtype m of
+ ("module" +++ prt i +++
+ "has open interfaces and must therefore be declared incomplete")
+ case mtype m of
MTInstance i0 -> do
- m0 <- lookupModule gr i0
- m' <- case m0 of
- ModMod m1 | isResourceModule m0 -> do ---- mtype m1 == MTInterface -> do
----- checkCompleteInstance m1 m -- do this later, in CheckGrammar
- js' <- extendMod i (jments m1) (jments m)
- return $ replaceJudgements m js'
- _ -> prtBad "interface expected instead of" i0
- return mi -----
+ m1 <- lookupModMod gr i0
+ testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
+ m' <- do
+ js' <- extendMod False i0 (jments m1) (jments m)
+ return $ replaceJudgements m js'
+ return $ ModMod m'
_ -> return mi
- return mi'
-- add the instance opens to an incomplete module "with" instances
ModWith mt stat ext ops -> do
- let insts = [(inf,inst) |OQualif _ inf inst <- ops]
+ let insts = [(inf,inst) | OQualif _ inf inst <- ops]
let infs = map fst insts
let stat' = ifNull MSComplete (const MSIncomplete)
[i | i <- is, notElem i infs]
testErr (stat' == MSComplete || stat == MSIncomplete)
("module" +++ prt i +++ "remains incomplete")
- Module mt0 stat0 fs me ops0 js <- do
- mi <- lookupModule gr ext
- case mi of
- ModMod m -> return m --- check compatibility of module type
- _ -> prtBad "expected regular module in 'with' clause, not" ext
+ Module mt0 _ fs me ops0 js <- lookupModMod gr ext
let ops1 = ops ++ [o | o <- ops0, notElem (openedModule o) infs]
++ [oQualif i i | i <- map snd insts] ----
+ ++ [oSimple i | i <- map snd insts] ----
--- check if me is incomplete
- return $ ModMod $ Module mt0 stat' fs me ops1
- (mapTree (qualifInstanceInfo insts) js)
+ return $ ModMod $ Module mt0 stat' fs me ops1 js
+ ---- (mapTree (qualifInstanceInfo insts) js) -- not needed
_ -> return mi
return (i,mi')
@@ -72,6 +67,7 @@ checkCompleteInstance abs cnc = ifNull (return ()) (Bad . unlines) $
then id
else (("Error: no definition given to" +++ prt f):)
+{- ---- should not be needed
qualifInstanceInfo :: [(Ident,Ident)] -> (Ident,Info) -> (Ident,Info)
qualifInstanceInfo insts (c,i) = (c,qualInfo i) where
@@ -95,5 +91,5 @@ qualifInstanceInfo insts (c,i) = (c,qualInfo i) where
qualLin (Just (c,(co,t))) = (Just (c,([(x,qual t) | (x,t) <- co], qual t)))
qualLin Nothing = Nothing
-
-- NB constructor patterns never appear in interfaces so we need not rename them
+-}
diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs
index 3a0bf5c52..20914ecc1 100644
--- a/src/GF/Compile/Rename.hs
+++ b/src/GF/Compile/Rename.hs
@@ -33,39 +33,13 @@ renameSourceTerm g m t = do
renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
- ModMod (Module mt st fs me ops js) -> do
- (_,mod1@(ModMod m)) <- extendModule ms (name,mod)
+ ModMod m@(Module mt st fs me ops js) -> do
let js1 = jments m
- status <- buildStatus (MGrammar ms) name mod1
+ status <- buildStatus (MGrammar ms) name mod
js2 <- mapMTree (renameInfo status) js1
let mod2 = ModMod $ Module mt st fs me (map forceQualif ops) js2
return $ (name,mod2) : ms
-extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
-extendModule ms (name,mod) = case mod of
- ModMod (Module mt st fs me ops js0) -> do
- js <- case mt of
-{- --- building the {s : Str} lincat
- MTConcrete a -> do
- ModMod ma <- lookupModule (MGrammar ms) a
- let cats = [c | (c,AbsCat _ _) <- tree2list $ jments ma]
- jscs = [(c,CncCat (yes defLinType) nope nope) | c <- cats]
- return $ updatesTreeNondestr jscs js0
--}
- _ -> return js0
- js1 <- case me of
- Just n -> do
- m0 <- case lookup n ms of
- Just (ModMod m) -> do
- testErr (sameMType (mtype m) mt)
- ("illegal extension type to module" +++ prt name)
- return m
- _ -> Bad $ "cannot find extended module" +++ prt n
- extendMod n (jments m0) js
- _ -> return js
- return $ (name,ModMod (Module mt st fs me ops js1))
-
-
type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])
type StatusTree = BinTree (Ident,StatusInfo)
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 18:28:46 +0000