summaryrefslogtreecommitdiff
path: root/src/GF/Compile
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Compile')
-rw-r--r--src/GF/Compile/CheckGrammar.hs52
-rw-r--r--src/GF/Compile/Compile.hs11
-rw-r--r--src/GF/Compile/Extend.hs4
-rw-r--r--src/GF/Compile/GrammarToCanon.hs19
-rw-r--r--src/GF/Compile/MkResource.hs2
-rw-r--r--src/GF/Compile/ModDeps.hs4
-rw-r--r--src/GF/Compile/Optimize.hs5
-rw-r--r--src/GF/Compile/RemoveLiT.hs4
-rw-r--r--src/GF/Compile/Rename.hs24
9 files changed, 75 insertions, 50 deletions
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index 8fe4cf988..7bfd2924e 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -37,24 +37,28 @@ showCheckModule mos m = do
checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule]
checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of
- ModMod mo@(Module mt fs me ops js) -> case mt of
- MTAbstract -> do
- js' <- mapMTree (checkAbsInfo gr name) js
- return $ (name, ModMod (Module mt fs me ops js')) : ms
-
- MTTransfer a b -> do
- js' <- mapMTree (checkAbsInfo gr name) js
- return $ (name, ModMod (Module mt fs me ops js')) : ms
-
- MTResource -> do
- js' <- mapMTree (checkResInfo gr) js
- return $ (name, ModMod (Module mt fs me ops js')) : ms
-
- MTConcrete a -> do
- ModMod abs <- checkErr $ lookupModule gr a
- checkCompleteGrammar abs mo
- js' <- mapMTree (checkCncInfo gr name (a,abs)) js
- return $ (name, ModMod (Module mt fs me ops js')) : ms
+ ModMod mo@(Module mt st fs me ops js) -> do
+ js' <- case mt of
+ MTAbstract -> mapMTree (checkAbsInfo gr name) js
+
+ MTTransfer a b -> mapMTree (checkAbsInfo gr name) js
+
+ MTResource -> mapMTree (checkResInfo gr) js
+
+ MTConcrete a -> do
+ ModMod abs <- checkErr $ lookupModule gr a
+ checkCompleteGrammar abs mo
+ mapMTree (checkCncInfo gr name (a,abs)) js
+
+ MTInterface -> mapMTree (checkResInfo gr) js
+
+ MTInstance a -> do
+ ModMod abs <- checkErr $ lookupModule gr a
+ checkCompleteInstance abs mo
+ mapMTree (checkResInfo gr) js
+
+ return $ (name, ModMod (Module mt st fs me ops js')) : ms
+
_ -> return $ (name,mod) : ms
where
gr = MGrammar $ (name,mod):ms
@@ -87,6 +91,18 @@ checkCompleteGrammar abs cnc = mapM_ checkWarn $
then id
else (("Warning: no linearization of" +++ prt f):)
+checkCompleteInstance :: SourceRes -> SourceRes -> Check ()
+checkCompleteInstance abs cnc = mapM_ checkWarn $
+ checkComplete [f | (f, ResOper (Yes _) _) <- abs'] cnc'
+ where
+ abs' = tree2list $ jments abs
+ cnc' = mapTree fst $ jments cnc
+ checkComplete sought given = foldr ckOne [] sought
+ where
+ ckOne f = if isInBinTree f given
+ then id
+ else (("Warning: no definition given to" +++ prt f):)
+
-- General Principle: only Yes-values are checked.
-- A May-value has always been checked in its origin module.
diff --git a/src/GF/Compile/Compile.hs b/src/GF/Compile/Compile.hs
index 1e49946a6..2a119878d 100644
--- a/src/GF/Compile/Compile.hs
+++ b/src/GF/Compile/Compile.hs
@@ -144,8 +144,7 @@ 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
@@ -158,7 +157,7 @@ compileSourceModule opts env@(k,gr,can) mo@(i,mi) = do
(k',mo3r:_) <- ioeErr $ refreshModule (k,mos) mo3
- mo4:_ <- putp " optimizing" $ ioeErr $ evalModule mos mo3r
+ mo4:_ <- putp " optimizing " $ ioeErr $ evalModule mos mo3r
return (k',mo4)
@@ -172,16 +171,16 @@ generateModuleCode opts path minfo@(name,info) = do
-- for resource, also emit gfr
case info of
- ModMod m | mtype m == MTResource && emit && nomulti -> do
+ ModMod m | isResourceModule info && isCompilableModule info && emit && nomulti -> do
let (file,out) = (gfrFile pname, prGrammar (MGrammar [minfo]))
ioeIO $ writeFile file out >> putStr (" wrote file" +++ file)
_ -> return ()
(file,out) <- do
code <- return $ MkGFC.prCanonModInfo minfo'
return (gfcFile pname, code)
- if emit && nomulti
+ if isCompilableModule info && emit && nomulti
then ioeIO $ writeFile file out >> putStr (" wrote file" +++ file)
- else return ()
+ else ioeIO $ putStrFlush "no need to save for this module "
return minfo'
where
nomulti = not $ oElem makeMulti opts
diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs
index 348cdf71d..5bb38a891 100644
--- a/src/GF/Compile/Extend.hs
+++ b/src/GF/Compile/Extend.hs
@@ -17,10 +17,10 @@ import Monad
extendModInfo :: Ident -> SourceModInfo -> SourceModInfo -> Err SourceModInfo
extendModInfo name old new = case (old,new) of
- (ModMod m0, ModMod (Module mt fs _ ops js)) -> do
+ (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 fs Nothing ops js)
+ return $ ModMod (Module mt st fs Nothing ops js)
-- this is what happens when extending a module: new information is inserted,
-- and the process is interrupted if unification fails
diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs
index 07708dd3c..ab493f761 100644
--- a/src/GF/Compile/GrammarToCanon.hs
+++ b/src/GF/Compile/GrammarToCanon.hs
@@ -28,7 +28,10 @@ showGFC = err id id . liftM (P.printTree . grammar2canon) . redGrammar
-- abstract syntax without dependent types
redGrammar :: SourceGrammar -> Err C.CanonGrammar
-redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo gr
+redGrammar (MGrammar gr) = liftM MGrammar $ mapM redModInfo $ filter active gr where
+ active (_,m) = case typeOfModule m of
+ MTInterface -> False
+ _ -> True
redModInfo :: (Ident, SourceModInfo) -> Err (Ident, C.CanonModInfo)
redModInfo (c,info) = do
@@ -43,19 +46,25 @@ redModInfo (c,info) = do
return (a', MTConcrete a')
MTAbstract -> return (c',MTAbstract) --- c' not needed
MTResource -> return (c',MTResource) --- c' not needed
+ MTInterface -> return (c',MTResource) ---- not needed
+ MTInstance _ -> return (c',MTResource) --- c' not needed
MTTransfer x y -> return (c',MTTransfer (om x) (om y)) --- c' not needed
- defss <- mapM (redInfo a) $ tree2list $ jments m
+
+ ---- this generates empty GFC. Better: none
+ let js = if mstatus m == MSIncomplete then NT else jments m
+
+ defss <- mapM (redInfo a) $ tree2list $ js
defs <- return $ sorted2tree $ concat defss -- sorted, but reduced
- return $ ModMod $ Module mt flags e os defs
+ return $ ModMod $ Module mt MSComplete flags e os defs
return (c',info')
where
redExtOpen m = do
e' <- case extends m of
Just e -> liftM Just $ redIdent e
_ -> return Nothing
- os' <- mapM (\ (OQualif _ i) -> liftM OSimple (redIdent i)) $ opens m
+ os' <- mapM (\ (OQualif q _ i) -> liftM (OSimple q) (redIdent i)) $ opens m
return (e',os')
- om = OSimple . openedModule --- normalizing away qualif
+ om = oSimple . openedModule --- normalizing away qualif
redInfo :: Ident -> (Ident,Info) -> Err [(Ident,C.Info)]
redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
diff --git a/src/GF/Compile/MkResource.hs b/src/GF/Compile/MkResource.hs
index 8b3a01793..90239cbf5 100644
--- a/src/GF/Compile/MkResource.hs
+++ b/src/GF/Compile/MkResource.hs
@@ -30,7 +30,7 @@ makeReuse gr r me c = do
_ -> prtBad "expected concrete to be the type of" c
_ -> prtBad "expected concrete to be the type of" c
- return $ Module MTResource flags me ops jms
+ return $ Module MTResource MSComplete flags me ops jms
mkResDefs :: Ident -> Ident -> Maybe Ident -> Maybe Ident ->
BinTree (Ident,Info) -> BinTree (Ident,Info) ->
diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs
index 2aa042a95..c940fdd7c 100644
--- a/src/GF/Compile/ModDeps.hs
+++ b/src/GF/Compile/ModDeps.hs
@@ -39,7 +39,7 @@ checkUniqueErr ms = do
checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
checkUniqueImportNames ns mo = case mo of
- ModMod m -> test [n | OQualif n v <- opens m, n /= v]
+ ModMod m -> test [n | OQualif _ n v <- opens m, n /= v]
where
@@ -80,7 +80,7 @@ moduleDeps ms = mapM deps ms where
-- check for superficial compatibility, not submodule relation etc
compatMType mt0 mt = case (mt0,mt) of
(MTConcrete _, MTConcrete _) -> True
- (MTResourceImpl _, MTResourceImpl _) -> True
+ (MTInstance _, MTInstance _) -> True
(MTReuse _, MTReuse _) -> True
---- some more
_ -> mt0 == mt
diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs
index 07149bebf..fe9b6b1af 100644
--- a/src/GF/Compile/Optimize.hs
+++ b/src/GF/Compile/Optimize.hs
@@ -29,7 +29,7 @@ evalModule :: [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) ->
Err [(Ident,SourceModInfo)]
evalModule ms mo@(name,mod) = case mod of
- ModMod (Module mt fs me ops js) -> case mt of
+ ModMod (Module mt st fs me ops js) | st == MSComplete -> case mt of
MTResource -> do
let deps = allOperDependencies name js
ids <- topoSortOpers deps
@@ -37,9 +37,10 @@ evalModule ms mo@(name,mod) = case mod of
return $ mod' : ms
MTConcrete a -> do
js' <- mapMTree (evalCncInfo gr0 name a) js
- return $ (name, ModMod (Module mt fs me ops js')) : ms
+ return $ (name, ModMod (Module mt st fs me ops js')) : ms
_ -> return $ (name,mod):ms
+ _ -> return $ (name,mod):ms
where
gr0 = MGrammar $ ms
gr = MGrammar $ (name,mod) : ms
diff --git a/src/GF/Compile/RemoveLiT.hs b/src/GF/Compile/RemoveLiT.hs
index 0e45be8c0..8dfaf412b 100644
--- a/src/GF/Compile/RemoveLiT.hs
+++ b/src/GF/Compile/RemoveLiT.hs
@@ -21,9 +21,9 @@ removeLiT gr = liftM MGrammar $ mapM (remlModule gr) (modules gr)
remlModule :: SourceGrammar -> (Ident,SourceModInfo) -> Err (Ident,SourceModInfo)
remlModule gr mi@(name,mod) = case mod of
- ModMod (Module mt fs me ops js) -> do
+ ModMod (Module mt st fs me ops js) -> do
js1 <- mapMTree (remlResInfo gr) js
- let mod2 = ModMod $ Module mt fs me ops js1
+ let mod2 = ModMod $ Module mt st fs me ops js1
return $ (name,mod2)
_ -> return mi
diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs
index 6f652820a..393f48a9c 100644
--- a/src/GF/Compile/Rename.hs
+++ b/src/GF/Compile/Rename.hs
@@ -32,17 +32,17 @@ 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 fs me ops js) -> do
+ ModMod (Module mt st fs me ops js) -> do
(_,mod1@(ModMod m)) <- extendModule ms (name,mod)
let js1 = jments m
status <- buildStatus (MGrammar ms) name mod1
js2 <- mapMTree (renameInfo status) js1
- let mod2 = ModMod $ Module mt fs me (map forceQualif ops) js2
+ 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 fs me ops js0) -> do
+ ModMod (Module mt st fs me ops js0) -> do
js <- case mt of
{- --- building the {s : Str} lincat
MTConcrete a -> do
@@ -62,7 +62,7 @@ extendModule ms (name,mod) = case mod of
_ -> Bad $ "cannot find extended module" +++ prt n
extendMod n (jments m0) js
_ -> return js
- return $ (name,ModMod (Module mt fs me ops js1))
+ return $ (name,ModMod (Module mt st fs me ops js1))
type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])
@@ -91,9 +91,9 @@ renameIdentTerm env@(act,imps) t =
return $ f c
_ -> return t
where
- opens = act : [st | (OSimple _,st) <- imps]
- qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
- [(m, st) | (OSimple m, st) <- imps] -- qualifying is always possible
+ opens = act : [st | (OSimple _ _,st) <- imps]
+ qualifs = [(m, st) | (OQualif _ m _, st) <- imps] ++
+ [(m, st) | (OSimple _ m, st) <- imps] -- qualifying is always possible
--- would it make sense to optimize this by inlining?
renameIdentPatt :: Status -> Patt -> Err Patt
@@ -114,14 +114,14 @@ info2status mq (c,i) = (c, case i of
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))
+ OSimple _ i -> mapTree (info2status (Just i))
+ OQualif _ i j -> mapTree (info2status (Just j))
buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Err Status
buildStatus gr c mo = let mo' = self2status c mo in case mo of
ModMod m -> do
let gr1 = MGrammar $ (c,mo) : modules gr
- ops = [OSimple e | e <- allExtends gr1 c] ++ allOpens m
+ ops = [OSimple OQNormal e | e <- allExtends gr1 c] ++ allOpens m
mods <- mapM (lookupModule gr1 . openedModule) ops
let sts = map modInfo2status $ zip ops mods
return $ if isModCnc m
@@ -144,8 +144,8 @@ self2status c i = mapTree (info2status (Just c)) js where -- qualify internal
_ -> True
forceQualif o = case o of
- OSimple i -> OQualif i i
- OQualif _ i -> OQualif i i
+ OSimple q i -> OQualif q i i
+ OQualif q _ i -> OQualif q i i
renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info)
renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 21:59:12 +0000