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

refactor the GF.Grammar.Grammar syntax. The obsolete constructions are removed

Browse Source
This commit is contained in:
krasimir
2009-01-19 13:23:03 +00:00
parent 47b60d0b88
commit 4f093feb49
25 changed files with 325 additions and 542 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
src/GF/Compile.hs
View File

@@ -39,6 +39,7 @@ import System.Time
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.List(nub)
import Data.Maybe (isNothing)
import PGF.Check
import PGF.CId
@@ -172,12 +173,9 @@ compileOne opts env@(_,srcgr,_) file = do
-- sm is optimized before generation, but not in the env
extendCompileEnvInt env k' (Just gfo) sm1
where
isConcr (_,mi) = case mi of
ModMod m -> isModCnc m && mstatus m /= MSIncomplete
_ -> False
isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete && isNothing (mwith m)
compileSourceModule :: Options -> CompileEnv ->
SourceModule -> IOE (Int,SourceModule)
compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
let putp = putPointE Normal opts
@@ -191,7 +189,7 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
intermOut opts DumpExtend (prModule mo1b)
case mo1b of
(_,ModMod n) | not (isCompleteModule n) -> do
(_,n) | not (isCompleteModule n) -> do
return (k,mo1b) -- refresh would fail, since not renamed
_ -> do
mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b

7
src/GF/Compile/BackOpt.hs
View File

@@ -32,11 +32,8 @@ import qualified Data.Set as Set
type OptSpec = Set Optimization
shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
shareModule opt (i,m) = case m of
M.ModMod mo ->
(i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo))))
_ -> (i,m)
shareModule :: OptSpec -> SourceModule -> SourceModule
shareModule opt (i,mo) = (i,M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo)))
shareInfo :: OptSpec -> (Ident, Info) -> Info
shareInfo opt (c, CncCat ty (Yes t) m) = CncCat ty (Yes (shareOptim opt c t)) m

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

@@ -63,9 +63,7 @@ mapsCheckTree f = checkErr . mapsErrTree (\t -> checkStart (f t) >>= return . fs
-- | checking is performed in the dependency order of modules
checkModule :: [SourceModule] -> SourceModule -> Check [SourceModule]
checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod of
ModMod mo -> do
checkModule ms (name,mo) = checkIn ("checking module" +++ prt name) $ do
let js = jments mo
checkRestrictedInheritance ms (name, mo)
js' <- case mtype mo of
@@ -77,29 +75,25 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod
MTConcrete a -> do
checkErr $ topoSortOpers $ allOperDependencies name js
ModMod abs <- checkErr $ lookupModule gr a
abs <- checkErr $ lookupModule gr a
js1 <- checkCompleteGrammar abs mo
mapsCheckTree (checkCncInfo gr name mo (a,abs)) js1
MTInterface -> mapsCheckTree (checkResInfo gr name mo) js
MTInstance a -> do
-- ModMod abs <- checkErr $ lookupModule gr a
-- checkCompleteInstance abs mo -- this is done in Rebuild
mapsCheckTree (checkResInfo gr name mo) js
return $ (name, ModMod (replaceJudgements mo js')) : ms
_ -> return $ (name,mod) : ms
return $ (name, replaceJudgements mo js') : ms
where
gr = MGrammar $ (name,mod):ms
gr = MGrammar $ (name,mo):ms
-- check if restricted inheritance modules are still coherent
-- i.e. that the defs of remaining names don't depend on omitted names
---checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check ()
checkRestrictedInheritance :: [SourceModule] -> SourceModule -> Check ()
checkRestrictedInheritance mos (name,mo) = do
let irs = [ii | ii@(_,mi) <- extend mo, mi /= MIAll] -- names with restr. inh.
let mrs = [((i,m),mi) | (i,ModMod m) <- mos, Just mi <- [lookup i irs]]
let mrs = [((i,m),mi) | (i,m) <- mos, Just mi <- [lookup i irs]]
-- the restr. modules themself, with restr. infos
mapM_ checkRem mrs
where
@@ -115,10 +109,7 @@ checkRestrictedInheritance mos (name,mo) = do
", dependence of excluded constants:" ++++
unlines [" " ++ prt f +++ "on" +++ unwords (map prt is) |
(f,is) <- cs]
allDeps = ---- transClosure $ Map.fromList $
concatMap (allDependencies (const True))
[jments m | (_,ModMod m) <- mos]
transClosure ds = ds ---- TODO: check in deeper modules
allDeps = concatMap (allDependencies (const True) . jments . snd) mos
-- | check if a term is typable
justCheckLTerm :: SourceGrammar -> Term -> Err Term
@@ -127,7 +118,7 @@ justCheckLTerm src t = do
return t'
checkAbsInfo ::
SourceGrammar -> Ident -> Module Ident Info -> (Ident,Info) -> Check (Ident,Info)
SourceGrammar -> Ident -> SourceModInfo -> (Ident,Info) -> Check (Ident,Info)
checkAbsInfo st m mo (c,info) = do
---- checkReservedId c
case info of
@@ -183,7 +174,7 @@ checkAbsInfo st m mo (c,info) = do
R fs -> mkApp t (map (snd . snd) fs)
_ -> mkApp t [a]
checkCompleteGrammar :: SourceAbs -> SourceCnc -> Check (BinTree Ident Info)
checkCompleteGrammar :: SourceModInfo -> SourceModInfo -> Check (BinTree Ident Info)
checkCompleteGrammar abs cnc = do
let jsa = jments abs
let fsa = tree2list jsa
@@ -227,8 +218,7 @@ checkCompleteGrammar abs cnc = do
-- | General Principle: only Yes-values are checked.
-- A May-value has always been checked in its origin module.
checkResInfo ::
SourceGrammar -> Ident -> Module Ident Info -> (Ident,Info) -> Check (Ident,Info)
checkResInfo :: SourceGrammar -> Ident -> SourceModInfo -> (Ident,Info) -> Check (Ident,Info)
checkResInfo gr mo mm (c,info) = do
checkReservedId c
case info of
@@ -281,8 +271,8 @@ checkResInfo gr mo mm (c,info) = do
_ -> return ()
checkCncInfo :: SourceGrammar -> Ident -> Module Ident Info ->
(Ident,SourceAbs) ->
checkCncInfo :: SourceGrammar -> Ident -> SourceModInfo ->
(Ident,SourceModInfo) ->
(Ident,Info) -> Check (Ident,Info)
checkCncInfo gr m mo (a,abs) (c,info) = do
checkReservedId c

15
src/GF/Compile/Coding.hs
View File

@@ -14,17 +14,14 @@ encodeStringsInModule :: SourceModule -> SourceModule
encodeStringsInModule = codeSourceModule encodeUTF8
decodeStringsInModule :: SourceModule -> SourceModule
decodeStringsInModule mo = case mo of
(_,ModMod m) -> case flag optEncoding (flags m) of
UTF_8 -> codeSourceModule decodeUTF8 mo
decodeStringsInModule mo =
case flag optEncoding (flagsModule mo) of
UTF_8 -> codeSourceModule decodeUTF8 mo
CP_1251 -> codeSourceModule decodeCP1251 mo
_ -> mo
_ -> mo
_ -> mo
codeSourceModule :: (String -> String) -> SourceModule -> SourceModule
codeSourceModule co (id,moi) = case moi of
ModMod mo -> (id, ModMod $ replaceJudgements mo (mapTree codj (jments mo)))
_ -> (id,moi)
codeSourceModule :: (String -> String) -> SourceModule -> SourceModule
codeSourceModule co (id,mo) = (id,replaceJudgements mo (mapTree codj (jments mo)))
where
codj (c,info) = case info of
ResOper pty pt -> ResOper (mapP codt pty) (mapP codt pt)

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

@@ -29,20 +29,17 @@ import GF.Data.Operations
import Control.Monad
extendModule :: [SourceModule] -> SourceModule -> Err SourceModule
extendModule ms (name,mod) = case mod of
extendModule ms (name,m)
---- Just to allow inheritance in incomplete concrete (which are not
---- compiled anyway), extensions are not built for them.
---- Should be replaced by real control. AR 4/2/2005
ModMod m | mstatus m == MSIncomplete && isModCnc m -> return (name,mod)
ModMod m -> do
mod' <- foldM extOne m (extend m)
return (name,ModMod mod')
| mstatus m == MSIncomplete && isModCnc m = return (name,m)
| otherwise = do m' <- foldM extOne m (extend m)
return (name,m')
where
extOne mo (n,cond) = do
(m0,isCompl) <- do
m <- lookupModMod (MGrammar ms) n
m <- lookupModule (MGrammar ms) n
-- test that the module types match, and find out if the old is complete
testErr (sameMType (mtype m) (mtype mo))

30
src/GF/Compile/GrammarToGFCC.hs
View File

@@ -58,7 +58,7 @@ addParsers opts pgf = CM.mapConcretes conv pgf
-- this assumes a grammar translated by canon2canon
canon2gfcc :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.PGF
canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) =
(if dump opts DumpCanon then trace (prGrammar cgr) else id) $
D.PGF an cns gflags abs cncs
where
@@ -82,7 +82,7 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
catfuns = Map.fromList
[(cat,[f | (f, (C.DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,M.ModMod mo) <- cms]
cncs = Map.fromList [mkConcr lang (i2i lang) mo | (lang,mo) <- cms]
mkConcr lang0 lang mo =
(lang,D.Concr flags lins opers lincats lindefs printnames params fcfg)
where
@@ -223,20 +223,18 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
reorder :: Ident -> SourceGrammar -> SourceGrammar
reorder abs cg = M.MGrammar $
(abs, M.ModMod $
M.Module M.MTAbstract M.MSComplete aflags [] [] adefs poss):
[(c, M.ModMod $
M.Module (M.MTConcrete abs) M.MSComplete fs [] [] (sorted2tree js) poss)
(abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] adefs poss):
[(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] (sorted2tree js) poss)
| (c,(fs,js)) <- cncs]
where
poss = emptyBinTree -- positions no longer needed
mos = M.allModMod cg
mos = M.modules cg
adefs = sorted2tree $ sortIds $
predefADefs ++ Look.allOrigInfos cg abs
predefADefs =
[(c, AbsCat (Yes []) Nope) | c <- [cFloat,cInt,cString]]
aflags =
concatOptions [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo]
concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo]
cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs]
concr la = (flags,
@@ -257,7 +255,7 @@ reorder abs cg = M.MGrammar $
repartition :: Ident -> SourceGrammar -> [SourceGrammar]
repartition abs cg =
[M.partOfGrammar cg (lang,mo) |
let mos = M.allModMod cg,
let mos = M.modules cg,
lang <- case M.allConcretes cg abs of
[] -> [abs] -- to make pgf nonempty even when there are no concretes
cncs -> cncs,
@@ -276,10 +274,8 @@ canon2canon opts abs cg0 =
js2js ms = map (c2c (j2j (M.MGrammar ms))) ms
c2c f2 (c,m) = case m of
M.ModMod mo ->
(c, M.ModMod $ M.replaceJudgements mo $ mapTree f2 (M.jments mo))
_ -> (c,m)
c2c f2 (c,mo) = (c, M.replaceJudgements mo $ mapTree f2 (M.jments mo))
j2j cg (f,j) =
let debug = if verbAtLeast opts Verbose then trace ("+ " ++ prt f) else id in
case j of
@@ -323,7 +319,7 @@ purgeGrammar abstr gr =
needed = nub $ concatMap (requiredCanModules isSingle gr) acncs
acncs = abstr : M.allConcretes gr abstr
isSingle = True
complete (i,M.ModMod m) = M.isCompleteModule m --- not . isIncompleteCanon
complete (i,m) = M.isCompleteModule m --- not . isIncompleteCanon
unopt = unshareModule gr -- subexp elim undone when compiled
type ParamEnv =
@@ -373,7 +369,7 @@ paramValues cgr = (labels,untyps,typs) where
updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
_ -> GM.composOp typsFromTrm tr
mods = traceD (unwords (map (prt . fst) ms)) ms where ms = M.allModMod cgr
mods = traceD (unwords (map (prt . fst) ms)) ms where ms = M.modules cgr
jments =
[(m,j) | (m,mo) <- mods, j <- tree2list $ M.jments mo]
@@ -555,8 +551,8 @@ requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
then map fst (M.modules gr)
else iterFix (concatMap more) $ exts
more i = errVal [] $ do
m <- M.lookupModMod gr i
m <- M.lookupModule gr i
return $ M.extends m ++ [o | o <- map M.openedModule (M.opens m)]
notReuse i = errVal True $ do
m <- M.lookupModMod gr i
m <- M.lookupModule gr i
return $ M.isModRes m -- to exclude reused Cnc and Abs from required

25
src/GF/Compile/ModDeps.hs
View File

@@ -36,7 +36,7 @@ import Data.List
-- | to check uniqueness of module names and import names, the
-- appropriateness of import and extend types,
-- to build a dependency graph of modules, and to sort them topologically
mkSourceGrammar :: [(Ident,SourceModInfo)] -> Err SourceGrammar
mkSourceGrammar :: [SourceModule] -> Err SourceGrammar
mkSourceGrammar ms = do
let ns = map fst ms
checkUniqueErr ns
@@ -55,23 +55,18 @@ checkUniqueErr ms = do
-- | check that import names don't clash with module names
checkUniqueImportNames :: [Ident] -> SourceModInfo -> Err ()
checkUniqueImportNames ns mo = case mo of
ModMod m -> test [n | OQualif _ n v <- opens m, n /= v]
_ -> return () --- Bad $ "bug: ModDeps does not treat" +++ show mo
checkUniqueImportNames ns mo = test [n | OQualif n v <- opens mo, n /= v]
where
test ms = testErr (all (`notElem` ns) ms)
("import names clashing with module names among" +++
unwords (map prt ms))
test ms = testErr (all (`notElem` ns) ms)
("import names clashing with module names among" +++ unwords (map prt ms))
type Dependencies = [(IdentM Ident,[IdentM Ident])]
-- | to decide what modules immediately depend on what, and check if the
-- dependencies are appropriate
moduleDeps :: [(Ident,SourceModInfo)] -> Err Dependencies
moduleDeps :: [SourceModule] -> Err Dependencies
moduleDeps ms = mapM deps ms where
deps (c,mi) = errIn ("checking dependencies of module" +++ prt c) $ case mi of
ModMod m -> case mtype m of
deps (c,m) = errIn ("checking dependencies of module" +++ prt c) $ case mtype m of
MTConcrete a -> do
aty <- lookupModuleType gr a
testErr (aty == MTAbstract) "the of-module is not an abstract syntax"
@@ -98,7 +93,6 @@ moduleDeps ms = mapM deps ms where
(MTInterface, MTAbstract) -> True
(MTConcrete _, MTConcrete _) -> True
(MTInstance _, MTInstance _) -> True
(MTReuse _, MTReuse _) -> True
(MTInstance _, MTResource) -> True
(MTResource, MTInstance _) -> True
---- some more?
@@ -109,7 +103,6 @@ moduleDeps ms = mapM deps ms where
MTTransfer _ _ -> mt == MTAbstract
_ -> case mt of
MTResource -> True
MTReuse _ -> True
MTInterface -> True
MTInstance _ -> True
_ -> False
@@ -129,13 +122,13 @@ requiredCanModules :: (Ord i, Show i) => Bool -> MGrammar i a -> i -> [i]
requiredCanModules isSingle gr c = nub $ filter notReuse ops ++ exts where
exts = allExtends gr c
ops = if isSingle
then map fst (modules gr)
then map fst (modules gr)
else iterFix (concatMap more) $ exts
more i = errVal [] $ do
m <- lookupModMod gr i
m <- lookupModule gr i
return $ extends m ++ [o | o <- map openedModule (opens m)]
notReuse i = errVal True $ do
m <- lookupModMod gr i
m <- lookupModule gr i
return $ isModRes m -- to exclude reused Cnc and Abs from required

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

@@ -49,40 +49,38 @@ prtIf b t = if b then trace (" " ++ prt t) t else t
type EEnv = () --- not used
-- only do this for resource: concrete is optimized in gfc form
optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) ->
(Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv)
optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of
ModMod m0 | mstatus m0 == MSComplete && isModRes m0 -> do
optimizeModule :: Options -> ([SourceModule],EEnv) -> SourceModule -> Err (SourceModule,EEnv)
optimizeModule opts mse@(ms,eenv) mo@(_,mi)
| mstatus mi == MSComplete && isModRes mi = do
(mo1,_) <- evalModule oopts mse mo
let mo2 = shareModule optim mo1
return (mo2,eenv)
_ -> evalModule oopts mse mo
| otherwise = evalModule oopts mse mo
where
oopts = opts `addOptions` flagsModule mo
optim = flag optOptimizations oopts
evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) ->
Err ((Ident,SourceModInfo),EEnv)
evalModule oopts (ms,eenv) mo@(name,mod) = case mod of
evalModule :: Options -> ([SourceModule],EEnv) -> SourceModule -> Err (SourceModule,EEnv)
evalModule oopts (ms,eenv) mo@(name,m0)
| mstatus m0 == MSComplete =
case mtype m0 of
_ | isModRes m0 -> do
let deps = allOperDependencies name (jments m0)
ids <- topoSortOpers deps
MGrammar (mod' : _) <- foldM evalOp gr ids
return $ (mod',eenv)
ModMod m0 | mstatus m0 == MSComplete -> case mtype m0 of
_ | isModRes m0 -> do
let deps = allOperDependencies name (jments m0)
ids <- topoSortOpers deps
MGrammar (mod' : _) <- foldM evalOp gr ids
return $ (mod',eenv)
MTConcrete a -> do
js' <- mapMTree (evalCncInfo oopts gr name a) (jments m0)
return $ ((name,replaceJudgements m0 js'),eenv)
MTConcrete a -> do
js' <- mapMTree (evalCncInfo oopts gr name a) (jments m0)
return $ ((name, ModMod (replaceJudgements m0 js')),eenv)
_ -> return $ ((name,mod),eenv)
_ -> return $ ((name,mod),eenv)
_ -> return $ (mo,eenv)
| otherwise = return $ (mo,eenv)
where
gr0 = MGrammar $ ms
gr = MGrammar $ (name,mod) : ms
gr = MGrammar $ mo : ms
evalOp g@(MGrammar ((_, ModMod m) : _)) i = do
evalOp g@(MGrammar ((_,m) : _)) i = do
info <- lookupTree prt i $ jments m
info' <- evalResInfo oopts gr (i,info)
return $ updateRes g name i info'

37
src/GF/Compile/OptimizeGF.hs
View File

@@ -33,23 +33,19 @@ import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS
import Data.List
optModule :: (Ident, SourceModInfo) -> (Ident, SourceModInfo)
optModule :: SourceModule -> SourceModule
optModule = subexpModule . shareModule
shareModule = processModule optim
unoptModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
unoptModule :: SourceGrammar -> SourceModule -> SourceModule
unoptModule gr = unshareModule gr . unsubexpModule
unshareModule :: SourceGrammar -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
unshareModule :: SourceGrammar -> SourceModule -> SourceModule
unshareModule gr = processModule (const (unoptim gr))
processModule ::
(Ident -> Term -> Term) -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
processModule opt (i,m) = case m of
M.ModMod mo ->
(i,M.ModMod (M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo))))
_ -> (i,m)
processModule :: (Ident -> Term -> Term) -> SourceModule -> SourceModule
processModule opt (i,mo) = (i,M.replaceJudgements mo (mapTree (shareInfo opt) (M.jments mo)))
shareInfo :: (Ident -> Term -> Term) -> (Ident,Info) -> Info
shareInfo opt (c, CncCat ty (Yes t) m) = CncCat ty (Yes (opt c t)) m
@@ -169,22 +165,19 @@ cse is possible in the grammar. It is used by the flag pg -printer=subs.
-}
subexpModule :: SourceModule -> SourceModule
subexpModule (n,m) = errVal (n,m) $ case m of
M.ModMod mo -> do
let ljs = tree2list (M.jments mo)
(tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0)
js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs
return (n,M.ModMod (M.replaceJudgements mo js2))
_ -> return (n,m)
subexpModule (n,mo) = errVal (n,mo) $ do
let ljs = tree2list (M.jments mo)
(tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0)
js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs
return (n,M.replaceJudgements mo js2)
unsubexpModule :: SourceModule -> SourceModule
unsubexpModule sm@(i,m) = case m of
M.ModMod mo | hasSub ljs ->
(i, M.ModMod (M.replaceJudgements mo
(rebuild (map unparInfo ljs))))
where ljs = tree2list (M.jments mo)
_ -> (i,m)
unsubexpModule sm@(i,mo)
| hasSub ljs = (i,M.replaceJudgements mo (rebuild (map unparInfo ljs)))
| otherwise = sm
where
ljs = tree2list (M.jments mo)
-- perform this iff the module has opers
hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
unparInfo (c,info) = case info of

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

@@ -27,6 +27,7 @@ import GF.Infra.Option
import GF.Data.Operations
import Data.List (nub)
import Data.Maybe (isNothing)
-- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003
@@ -39,13 +40,13 @@ rebuildModule ms mo@(i,mi) = do
mi' <- case mi of
-- add the information given in interface into an instance module
ModMod m -> do
m | isNothing (mwith m) -> do
testErr (null is || mstatus m == MSIncomplete)
("module" +++ prt i +++
"has open interfaces and must therefore be declared incomplete")
case mtype m of
MTInstance i0 -> do
m1 <- lookupModMod gr i0
m1 <- lookupModule gr i0
testErr (isModRes m1) ("interface expected instead of" +++ prt i0)
m' <- do
js' <- extendMod False (i0,const True) i (jments m1) (jments m)
@@ -53,7 +54,7 @@ rebuildModule ms mo@(i,mi) = do
case extends m of
[] -> return $ replaceJudgements m js'
j0s -> do
m0s <- mapM (lookupModMod gr) j0s
m0s <- mapM (lookupModule gr) j0s
let notInM0 c _ = all (not . isInBinTree c . jments) m0s
let js2 = filterBinTree notInM0 js'
return $ (replaceJudgements m js2)
@@ -61,37 +62,35 @@ rebuildModule ms mo@(i,mi) = do
buildTree (tree2list (positions m1) ++
tree2list (positions m))}
-- checkCompleteInstance m1 m'
return $ ModMod m'
return m'
_ -> return mi
-- add the instance opens to an incomplete module "with" instances
-- ModWith mt stat ext me ops -> do
ModWith (Module mt stat fs_ me ops_ js_ ps_) (ext,incl) ops -> do
let insts = [(inf,inst) | OQualif _ inf inst <- ops]
ModInfo mt stat fs_ me (Just (ext,incl,ops)) ops_ js_ ps_ -> do
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 _ fs me' ops0 js ps0 <- lookupModMod gr ext
ModInfo mt0 _ fs me' _ ops0 js ps0 <- lookupModule gr ext
let ops1 = nub $
ops_ ++ -- N.B. js has been name-resolved already
ops ++ [o | o <- ops0, notElem (openedModule o) infs]
++ [oQualif i i | i <- map snd insts] ----
++ [oSimple i | i <- map snd insts] ----
++ [OQualif i i | i <- map snd insts] ----
++ [OSimple i | i <- map snd insts] ----
--- check if me is incomplete
let fs1 = fs `addOptions` fs_ -- new flags have priority
let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0)
let ps1 = buildTree (tree2list ps_ ++ tree2list ps0)
return $ ModMod $ Module mt0 stat' fs1 me ops1 js1 ps1
---- (mapTree (qualifInstanceInfo insts) js) -- not needed
return $ ModInfo mt0 stat' fs1 me Nothing ops1 js1 ps1
_ -> return mi
return (i,mi')
checkCompleteInstance :: SourceRes -> SourceRes -> Err ()
checkCompleteInstance :: SourceModInfo -> SourceModInfo -> Err ()
checkCompleteInstance abs cnc = ifNull (return ()) (Bad . unlines) $
checkComplete [f | (f, ResOper (Yes _) _) <- abs'] cnc'
where

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

@@ -109,11 +109,11 @@ refreshGrammar :: SourceGrammar -> Err SourceGrammar
refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules
refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule])
refreshModule (k,ms) mi@(i,m) = case m of
ModMod mo | (isModCnc mo || isModRes mo) -> do
refreshModule (k,ms) mi@(i,mo)
| isModCnc mo || isModRes mo = do
(k',js') <- foldM refreshRes (k,[]) $ tree2list $ jments mo
return (k', (i, ModMod(replaceJudgements mo (buildTree js'))) : ms)
_ -> return (k, mi:ms)
return (k', (i, replaceJudgements mo (buildTree js')) : ms)
| otherwise = return (k, mi:ms)
where
refreshRes (k,cs) ci@(c,info) = case info of
ResOper ptyp (Yes trm) -> do ---- refresh ptyp

15
src/GF/Compile/RemoveLiT.hs
View File

@@ -32,13 +32,10 @@ import Control.Monad
removeLiT :: SourceGrammar -> Err SourceGrammar
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 mo -> do
js1 <- mapMTree (remlResInfo gr) (jments mo)
let mod2 = ModMod $ mo {jments = js1}
return $ (name,mod2)
_ -> return mi
remlModule :: SourceGrammar -> SourceModule -> Err SourceModule
remlModule gr mi@(name,mo) = do
js1 <- mapMTree (remlResInfo gr) (jments mo)
return (name,mo{jments = js1})
remlResInfo :: SourceGrammar -> (Ident,Info) -> Err Info
remlResInfo gr (i,info) = case info of
@@ -59,6 +56,6 @@ remlTerm gr trm = case trm of
_ -> composOp (remlTerm gr) trm
where
look c = err (const $ return defLinType) return $ lookupLincat gr m c
m = case [cnc | (cnc,ModMod m) <- modules gr, isModCnc m] of
m = case [cnc | (cnc,m) <- modules gr, isModCnc m] of
cnc:_ -> cnc -- actually there is always exactly one
_ -> cCNC
_ -> cCNC

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

@@ -49,18 +49,16 @@ renameGrammar g = liftM (MGrammar . reverse) $ foldM renameModule [] (modules g)
-- | this gives top-level access to renaming term input in the cc command
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Err Term
renameSourceTerm g m t = do
mo <- lookupErr m (modules g)
mo <- lookupModule g m
status <- buildStatus g m mo
renameTerm status [] t
renameModule :: [SourceModule] -> SourceModule -> Err [SourceModule]
renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod of
ModMod mo -> do
let js1 = jments mo
status <- buildStatus (MGrammar ms) name mod
js2 <- mapsErrTree (renameInfo mo status) js1
let mod2 = ModMod $ mo {opens = map forceQualif (opens mo), jments = js2}
return $ (name,mod2) : ms
renameModule ms (name,mo) = errIn ("renaming module" +++ prt name) $ do
let js1 = jments mo
status <- buildStatus (MGrammar ms) name mo
js2 <- mapsErrTree (renameInfo mo status) js1
return $ (name, mo {opens = map forceQualif (opens mo), jments = js2}) : ms
type Status = (StatusTree, [(OpenSpec Ident, StatusTree)])
@@ -86,9 +84,9 @@ renameIdentTerm env@(act,imps) t =
return $ f c
_ -> return t
where
opens = [st | (OSimple _ _,st) <- imps]
qualifs = [(m, st) | (OQualif _ m _, st) <- imps] ++
[(m, st) | (OSimple _ m, st) <- imps] -- qualif is always possible
opens = [st | (OSimple _,st) <- imps]
qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
[(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
-- this facility is mainly for BWC with GF1: you need not import PredefAbs
predefAbs c s
@@ -126,47 +124,38 @@ info2status mq (c,i) = 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 OQNormal e | e <- allExtends gr1 c] ++ allOpens m
buildStatus gr c mo = let mo' = self2status c mo in do
let gr1 = MGrammar ((c,mo) : modules gr)
ops = [OSimple e | e <- allExtends gr1 c] ++ allOpens mo
mods <- mapM (lookupModule gr1 . openedModule) ops
let sts = map modInfo2status $ zip ops mods
return $ if isModCnc m
return $ if isModCnc mo
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)
modInfo2status (o,i) = (o,case i of
ModMod m -> tree2status o (jments m)
)
modInfo2status (o,mo) = (o,tree2status o (jments mo))
self2status :: Ident -> SourceModInfo -> StatusTree
self2status c i = mapTree (info2status (Just c)) js where -- qualify internal
js = case i of
ModMod m
| isModTrans m -> sorted2tree $ filter noTrans $ tree2list $ jments m
| otherwise -> jments m
noTrans (_,d) = case d of -- to enable other than transfer js in transfer module
AbsTrans _ -> False
_ -> True
self2status c m = mapTree (info2status (Just c)) js where -- qualify internal
js | isModTrans m = sorted2tree $ tree2list $ jments m
| otherwise = jments m
forceQualif o = case o of
OSimple q i -> OQualif q i i
OQualif q _ i -> OQualif q i i
OSimple i -> OQualif i i
OQualif _ i -> OQualif i i
renameInfo :: Module Ident Info -> Status -> (Ident,Info) -> Err (Ident,Info)
renameInfo :: SourceModInfo -> Status -> (Ident,Info) -> Err (Ident,Info)
renameInfo mo status (i,info) = errIn
("renaming definition of" +++ prt i +++ showPosition mo i) $
liftM ((,) i) $ case info of
AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
(renPerh (mapM rent) pfs)
AbsFun pty ptr -> liftM2 AbsFun (ren pty) (ren ptr)
AbsTrans f -> liftM AbsTrans (rent f)
ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
ResOverload os tysts ->

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

@@ -32,11 +32,9 @@ import Control.Monad
-- | update a resource module by adding a new or changing an old definition
updateRes :: SourceGrammar -> Ident -> Ident -> Info -> SourceGrammar
updateRes gr@(MGrammar ms) m i info = MGrammar $ map upd ms where
upd (n,mod)
| n /= m = (n,mod)
| n == m = case mod of
ModMod r -> (m,ModMod $ updateModule r i info)
_ -> (n,mod) --- no error msg
upd (n,mo)
| n /= m = (n,mo)
| n == m = (n,updateModule mo i info)
-- | combine a list of definitions into a balanced binary search tree
buildAnyTree :: [(Ident,Info)] -> Err (BinTree Ident Info)

12
src/GF/Grammar/Grammar.hs
View File

@@ -18,9 +18,6 @@ module GF.Grammar.Grammar (SourceGrammar,
emptySourceGrammar,
SourceModInfo,
SourceModule,
SourceAbs,
SourceRes,
SourceCnc,
mapSourceModule,
Info(..),
PValues,
@@ -72,12 +69,8 @@ type SourceModInfo = ModInfo Ident Info
type SourceModule = (Ident, SourceModInfo)
type SourceAbs = Module Ident Info
type SourceRes = Module Ident Info
type SourceCnc = Module Ident Info
mapSourceModule :: (Module Ident Info -> Module Ident Info) -> SourceModule -> SourceModule
mapSourceModule f (i,mi) = (i, mapModules' f mi)
mapSourceModule :: (SourceModInfo -> SourceModInfo) -> (SourceModule -> SourceModule)
mapSourceModule f (i,mi) = (i, f mi)
-- this is created in CheckGrammar, and so are Val and PVal
type PValues = [Term]
@@ -95,7 +88,6 @@ data Info =
-- judgements in abstract syntax
AbsCat (Perh Context) (Perh [Term]) -- ^ (/ABS/) constructors; must be 'Id' or 'QId'
| AbsFun (Perh Type) (Perh Term) -- ^ (/ABS/) 'Yes f' = canonical
| AbsTrans Term -- ^ (/ABS/)
-- judgements in resource
| ResParam (Perh ([Param],Maybe PValues)) -- ^ (/RES/)

30
src/GF/Grammar/LookAbs.hs
View File

@@ -29,25 +29,19 @@ import Control.Monad
-- | this is needed at compile time
lookupFunType :: Grammar -> Ident -> Ident -> Err Type
lookupFunType gr m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
AbsFun (Yes t) _ -> return t
AnyInd _ n -> lookupFunType gr n c
_ -> prtBad "cannot find type of" c
_ -> Bad $ prt m +++ "is not an abstract module"
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
AbsFun (Yes t) _ -> return t
AnyInd _ n -> lookupFunType gr n c
_ -> prtBad "cannot find type of" c
-- | this is needed at compile time
lookupCatContext :: Grammar -> Ident -> Ident -> Err Context
lookupCatContext gr m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
AbsCat (Yes co) _ -> return co
AnyInd _ n -> lookupCatContext gr n c
_ -> prtBad "unknown category" c
_ -> Bad $ prt m +++ "is not an abstract module"
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
AbsCat (Yes co) _ -> return co
AnyInd _ n -> lookupCatContext gr n c
_ -> prtBad "unknown category" c

147
src/GF/Grammar/Lookup.hs
View File

@@ -56,56 +56,50 @@ lookupResDefKind gr m c
---- was PredefAbs till 3/9/2008, with explanation: need this in gf3 12/6/2008
| otherwise = look True m c where
look isTop m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfoIn mo m c
case info of
ResOper _ (Yes t) -> return (qualifAnnot m t, 0)
ResOper _ Nope -> return (Q m c, 0) ---- if isTop then lookExt m c
mo <- lookupModule gr m
info <- lookupIdentInfoIn mo m c
case info of
ResOper _ (Yes t) -> return (qualifAnnot m t, 0)
ResOper _ Nope -> return (Q m c, 0) ---- if isTop then lookExt m c
---- else prtBad "cannot find in exts" c
CncCat (Yes ty) _ _ -> liftM (flip (,) 1) $ lock c ty
CncCat _ _ _ -> liftM (flip (,) 1) $ lock c defLinType
CncFun (Just (cat,_)) (Yes tr) _ -> liftM (flip (,) 1) $ unlock cat tr
CncCat (Yes ty) _ _ -> liftM (flip (,) 1) $ lock c ty
CncCat _ _ _ -> liftM (flip (,) 1) $ lock c defLinType
CncFun (Just (cat,_)) (Yes tr) _ -> liftM (flip (,) 1) $ unlock cat tr
CncFun _ (Yes tr) _ -> liftM (flip (,) 1) (return tr) ---- $ unlock c tr
CncFun _ (Yes tr) _ -> liftM (flip (,) 1) (return tr) ---- $ unlock c tr
AnyInd _ n -> look False n c
ResParam _ -> return (QC m c,2)
ResValue _ -> return (QC m c,2)
_ -> Bad $ prt c +++ "is not defined in resource" +++ prt m
_ -> Bad $ prt m +++ "is not a resource"
AnyInd _ n -> look False n c
ResParam _ -> return (QC m c,2)
ResValue _ -> return (QC m c,2)
_ -> Bad $ prt c +++ "is not defined in resource" +++ prt m
lookExt m c =
checks ([look False n c | n <- allExtensions gr m] ++ [return (Q m c,3)])
lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type
lookupResType gr m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
ResOper (Yes t) _ -> return $ qualifAnnot m t
ResOper (May n) _ -> lookupResType gr n c
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
ResOper (Yes t) _ -> return $ qualifAnnot m t
ResOper (May n) _ -> lookupResType gr n c
-- used in reused concrete
CncCat _ _ _ -> return typeType
CncFun (Just (cat,(cont@(_:_),val))) _ _ -> do
-- used in reused concrete
CncCat _ _ _ -> return typeType
CncFun (Just (cat,(cont@(_:_),val))) _ _ -> do
val' <- lock cat val
return $ mkProd (cont, val', [])
CncFun _ _ _ -> lookFunType m m c
AnyInd _ n -> lookupResType gr n c
ResParam _ -> return $ typePType
ResValue (Yes (t,_)) -> return $ qualifAnnotPar m t
_ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m
_ -> Bad $ prt m +++ "is not a resource"
CncFun _ _ _ -> lookFunType m m c
AnyInd _ n -> lookupResType gr n c
ResParam _ -> return $ typePType
ResValue (Yes (t,_)) -> return $ qualifAnnotPar m t
_ -> Bad $ prt c +++ "has no type defined in resource" +++ prt m
where
lookFunType e m c = do
a <- abstractOfConcrete gr m
lookFun e m c a
lookFun e m c a = do
mu <- lookupModMod gr a
mu <- lookupModule gr a
info <- lookupIdentInfo mu c
case info of
AbsFun (Yes ty) _ -> return $ redirectTerm e ty
@@ -115,44 +109,35 @@ lookupResType gr m c = do
lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))]
lookupOverload gr m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
ResOverload os tysts -> do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
ResOverload os tysts -> do
tss <- mapM (\x -> lookupOverload gr x c) os
return $ [(map snd args,(val,tr)) |
(ty,tr) <- tysts, Ok (args,val) <- [typeFormCnc ty]] ++
concat tss
AnyInd _ n -> lookupOverload gr n c
_ -> Bad $ prt c +++ "is not an overloaded operation"
_ -> Bad $ prt m +++ "is not a resource"
AnyInd _ n -> lookupOverload gr n c
_ -> Bad $ prt c +++ "is not an overloaded operation"
lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err Info
lookupOrigInfo gr m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
AnyInd _ n -> lookupOrigInfo gr n c
i -> return i
_ -> Bad $ prt m +++ "is not run-time module"
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
AnyInd _ n -> lookupOrigInfo gr n c
i -> return i
lookupParams :: SourceGrammar -> Ident -> Ident -> Err ([Param],Maybe PValues)
lookupParams gr = look True where
look isTop m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
ResParam (Yes psm) -> return psm
AnyInd _ n -> look False n c
_ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
_ -> Bad $ prt m +++ "is not a resource"
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
ResParam (Yes psm) -> return psm
AnyInd _ n -> look False n c
_ -> Bad $ prt c +++ "has no parameters defined in resource" +++ prt m
lookExt m c =
checks [look False n c | n <- allExtensions gr m]
@@ -190,11 +175,10 @@ lookupIndexValue gr ty i = do
allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
allOrigInfos gr m = errVal [] $ do
mi <- lookupModule gr m
case mi of
ModMod mo -> return [(c,i) | (c,_) <- tree2list (jments mo), Ok i <- [look c]]
where
look = lookupOrigInfo gr m
mo <- lookupModule gr m
return [(c,i) | (c,_) <- tree2list (jments mo), Ok i <- [look c]]
where
look = lookupOrigInfo gr m
allParamValues :: SourceGrammar -> Type -> Err [Term]
allParamValues cnc ptyp = case ptyp of
@@ -225,36 +209,29 @@ qualifAnnotPar m t = case t of
lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Term)
lookupAbsDef gr m c = errIn ("looking up absdef of" +++ prt c) $ do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
AbsFun _ (Yes t) -> return $ return t
AnyInd _ n -> lookupAbsDef gr n c
_ -> return Nothing
_ -> Bad $ prt m +++ "is not an abstract module"
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
AbsFun _ (Yes t) -> return (Just t)
AnyInd _ n -> lookupAbsDef gr n c
_ -> return Nothing
lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
lookupLincat gr m c = do
mi <- lookupModule gr m
case mi of
ModMod mo -> do
info <- lookupIdentInfo mo c
case info of
CncCat (Yes t) _ _ -> return t
AnyInd _ n -> lookupLincat gr n c
_ -> Bad $ prt c +++ "has no linearization type in" +++ prt m
_ -> Bad $ prt m +++ "is not concrete"
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
CncCat (Yes t) _ _ -> return t
AnyInd _ n -> lookupLincat gr n c
_ -> Bad $ prt c +++ "has no linearization type in" +++ prt m
-- The first type argument is uncomputed, usually a category symbol.
-- This is a hack to find implicit (= reused) opers.
opersForType :: SourceGrammar -> Type -> Type -> [(QIdent,Term)]
opersForType gr orig val =
[((i,f),ty) | (i,m) <- allModMod gr, (f,ty) <- opers i m val] where
[((i,f),ty) | (i,m) <- modules gr, (f,ty) <- opers i m val] where
opers i m val =
[(f,ty) |
(f,ResOper (Yes ty) _) <- tree2list $ jments m,
@@ -263,7 +240,7 @@ opersForType gr orig val =
] ++
let cat = err error snd (valCat orig) in --- ignore module
[(f,ty) |
Ok a <- [abstractOfConcrete gr i >>= lookupModMod gr],
Ok a <- [abstractOfConcrete gr i >>= lookupModule gr],
(f, AbsFun (Yes ty0) _) <- tree2list $ jments a,
let ty = redirectTerm i ty0,
Ok valt <- [valCat ty],

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

@@ -78,7 +78,7 @@ pprintTree = compactPrint . P.printTree
prGrammar :: SourceGrammar -> String
prGrammar = pprintTree . trGrammar
prModule :: (Ident, SourceModInfo) -> String
prModule :: SourceModule -> String
prModule = pprintTree . trModule
instance Print Term where
@@ -254,10 +254,10 @@ lookupIdent c t = case lookupTree prt c t of
Ok v -> return v
_ -> prtBad "unknown identifier" c
lookupIdentInfo :: Module Ident a -> Ident -> Err a
lookupIdentInfo :: ModInfo Ident a -> Ident -> Err a
lookupIdentInfo mo i = lookupIdent i (jments mo)
lookupIdentInfoIn :: Module Ident a -> Ident -> Ident -> Err a
lookupIdentInfoIn :: ModInfo Ident a -> Ident -> Ident -> Err a
lookupIdentInfoIn mo m i =
err (\s -> Bad (s +++ "in module" +++ prt m)) return $ lookupIdentInfo mo i

2
src/GF/Infra/Dependencies.hs
View File

@@ -46,7 +46,7 @@ data ModDeps = ModDeps {
noModDeps = ModDeps MTAbstract [] [] [] [] [] []
grammar2moddeps :: SourceGrammar -> [(Ident,ModDeps)]
grammar2moddeps gr = [(i,depMod m) | (i,ModMod m) <- modules gr] where
grammar2moddeps gr = [(i,depMod m) | (i,m) <- modules gr] where
depMod m = noModDeps{
modtype = mtype m,
ofs = case mtype m of

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

@@ -19,23 +19,22 @@
-----------------------------------------------------------------------------
module GF.Infra.Modules (
MGrammar(..), ModInfo(..), Module(..), ModuleType(..),
MReuseType(..), MInclude (..),
MGrammar(..), ModInfo(..), ModuleType(..),
MInclude (..),
extends, isInherited,inheritAll,
updateMGrammar, updateModule, replaceJudgements, addFlag,
addOpenQualif, flagsModule, allFlags, mapModules, mapModules',
MainGrammar(..), MainConcreteSpec(..), OpenSpec(..), OpenQualif(..),
oSimple, oQualif,
addOpenQualif, flagsModule, allFlags, mapModules,
OpenSpec(..),
ModuleStatus(..),
openedModule, allOpens, depPathModule, allDepsModule, partOfGrammar,
allExtends, allExtendSpecs, allExtendsPlus, allExtensions,
searchPathModule, addModule,
emptyMGrammar, emptyModInfo, emptyModule,
emptyMGrammar, emptyModInfo,
IdentM(..),
typeOfModule, abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupModMod, lookupInfo,
abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupInfo,
lookupPosition, showPosition,
allModMod, isModAbs, isModRes, isModCnc, isModTrans,
isModAbs, isModRes, isModCnc, isModTrans,
sameMType, isCompilableModule, isCompleteModule,
allAbstracts, greatestAbstract, allResources,
greatestResource, allConcretes, allConcreteModules
@@ -54,27 +53,22 @@ import Data.List
-- The parameters tell what kind of data is involved.
-- Invariant: modules are stored in dependency order
data MGrammar i a = MGrammar {modules :: [(i,ModInfo i a)]}
newtype MGrammar i a = MGrammar {modules :: [(i,ModInfo i a)]}
deriving Show
data ModInfo i a =
ModMainGrammar (MainGrammar i)
| ModMod (Module i a)
| ModWith (Module i a) (i,MInclude i) [OpenSpec i]
deriving Show
data Module i a = Module {
data ModInfo i a = ModInfo {
mtype :: ModuleType i ,
mstatus :: ModuleStatus ,
flags :: Options,
extend :: [(i,MInclude i)],
mwith :: Maybe (i,MInclude i,[OpenSpec i]),
opens :: [OpenSpec i] ,
jments :: BinTree i a ,
positions :: BinTree i (String,(Int,Int)) -- file, first line, last line
}
--- deriving Show
instance Show (Module i a) where
show _ = "cannot show Module with FiniteMap"
instance Show (ModInfo i a) where
show _ = "cannot show ModInfo with FiniteMap"
-- | encoding the type of the module
data ModuleType i =
@@ -85,17 +79,12 @@ data ModuleType i =
-- ^ up to this, also used in GFC. Below, source only.
| MTInterface
| MTInstance i
| MTReuse (MReuseType i)
| MTUnion (ModuleType i) [(i,[i])] -- ^ not meant to be recursive
deriving (Eq,Ord,Show)
data MReuseType i = MRInterface i | MRInstance i i | MRResource i
deriving (Eq,Ord,Show)
data MInclude i = MIAll | MIOnly [i] | MIExcept [i]
deriving (Eq,Ord,Show)
extends :: Module i a -> [i]
extends :: ModInfo i a -> [i]
extends = map fst . extend
isInherited :: Eq i => MInclude i -> i -> Bool
@@ -117,68 +106,32 @@ updateMGrammar old new = MGrammar $
os = modules old
ns = modules new
updateModule :: Ord i => Module i t -> i -> t -> Module i t
updateModule (Module mt ms fs me ops js ps) i t =
Module mt ms fs me ops (updateTree (i,t) js) ps
updateModule :: Ord i => ModInfo i t -> i -> t -> ModInfo i t
updateModule (ModInfo mt ms fs me mw ops js ps) i t = ModInfo mt ms fs me mw ops (updateTree (i,t) js) ps
replaceJudgements :: Module i t -> BinTree i t -> Module i t
replaceJudgements (Module mt ms fs me ops _ ps) js = Module mt ms fs me ops js ps
replaceJudgements :: ModInfo i t -> BinTree i t -> ModInfo i t
replaceJudgements (ModInfo mt ms fs me mw ops _ ps) js = ModInfo mt ms fs me mw ops js ps
addOpenQualif :: i -> i -> Module i t -> Module i t
addOpenQualif i j (Module mt ms fs me ops js ps) =
Module mt ms fs me (oQualif i j : ops) js ps
addOpenQualif :: i -> i -> ModInfo i t -> ModInfo i t
addOpenQualif i j (ModInfo mt ms fs me mw ops js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) js ps
addFlag :: Options -> Module i t -> Module i t
addFlag :: Options -> ModInfo i t -> ModInfo i t
addFlag f mo = mo {flags = flags mo `addOptions` f}
flagsModule :: (i,ModInfo i a) -> Options
flagsModule (_,mi) = case mi of
ModMod m -> flags m
_ -> noOptions
flagsModule (_,mi) = flags mi
allFlags :: MGrammar i a -> Options
allFlags gr = concatOptions $ map flags $ [m | (_, ModMod m) <- modules gr]
allFlags gr = concatOptions [flags m | (_,m) <- modules gr]
mapModules :: (Module i a -> Module i a)
-> MGrammar i a -> MGrammar i a
mapModules f = MGrammar . map (onSnd (mapModules' f)) . modules
mapModules' :: (Module i a -> Module i a)
-> ModInfo i a -> ModInfo i a
mapModules' f (ModMod m) = ModMod (f m)
mapModules' _ m = m
data MainGrammar i = MainGrammar {
mainAbstract :: i ,
mainConcretes :: [MainConcreteSpec i]
}
deriving Show
data MainConcreteSpec i = MainConcreteSpec {
concretePrintname :: i ,
concreteName :: i ,
transferIn :: Maybe (OpenSpec i) , -- ^ if there is an in-transfer
transferOut :: Maybe (OpenSpec i) -- ^ if there is an out-transfer
}
deriving Show
mapModules :: (ModInfo i a -> ModInfo i a) -> MGrammar i a -> MGrammar i a
mapModules f (MGrammar ms) = MGrammar (map (onSnd f) ms)
data OpenSpec i =
OSimple OpenQualif i
| OQualif OpenQualif i i
OSimple i
| OQualif i i
deriving (Eq,Ord,Show)
data OpenQualif =
OQNormal
| OQInterface
| OQIncomplete
deriving (Eq,Ord,Show)
oSimple :: i -> OpenSpec i
oSimple = OSimple OQNormal
oQualif :: i -> i -> OpenSpec i
oQualif = OQualif OQNormal
data ModuleStatus =
MSComplete
| MSIncomplete
@@ -186,29 +139,31 @@ data ModuleStatus =
openedModule :: OpenSpec i -> i
openedModule o = case o of
OSimple _ m -> m
OQualif _ _ m -> m
OSimple m -> m
OQualif _ m -> m
allOpens :: Module i a -> [OpenSpec i]
allOpens :: ModInfo i a -> [OpenSpec i]
allOpens m = case mtype m of
MTTransfer a b -> a : b : opens m
_ -> opens m
-- | initial dependency list
depPathModule :: Ord i => Module i a -> [OpenSpec i]
depPathModule m = fors m ++ exts m ++ opens m where
fors m = case mtype m of
MTTransfer i j -> [i,j]
MTConcrete i -> [oSimple i]
MTInstance i -> [oSimple i]
_ -> []
exts m = map oSimple $ extends m
depPathModule :: Ord i => ModInfo i a -> [OpenSpec i]
depPathModule m = fors m ++ exts m ++ opens m
where
fors m =
case mtype m of
MTTransfer i j -> [i,j]
MTConcrete i -> [OSimple i]
MTInstance i -> [OSimple i]
_ -> []
exts m = map OSimple (extends m)
-- | all dependencies
allDepsModule :: Ord i => MGrammar i a -> Module i a -> [OpenSpec i]
allDepsModule :: Ord i => MGrammar i a -> ModInfo i a -> [OpenSpec i]
allDepsModule gr m = iterFix add os0 where
os0 = depPathModule m
add os = [m | o <- os, Just (ModMod n) <- [lookup (openedModule o) mods],
add os = [m | o <- os, Just n <- [lookup (openedModule o) mods],
m <- depPathModule n]
mods = modules gr
@@ -217,48 +172,49 @@ partOfGrammar :: Ord i => MGrammar i a -> (i,ModInfo i a) -> MGrammar i a
partOfGrammar gr (i,m) = MGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
where
mods = modules gr
modsFor = case m of
ModMod n -> (i:) $ map openedModule $ allDepsModule gr n
---- ModWith n i os -> i : map openedModule os ++ partOfGrammar (ModMod n) ----
_ -> [i]
modsFor = (i:) $ map openedModule $ allDepsModule gr m
-- | all modules that a module extends, directly or indirectly, without restricts
allExtends :: (Show i,Ord i) => MGrammar i a -> i -> [i]
allExtends gr i = case lookupModule gr i of
Ok (ModMod m) -> case extends m of
[] -> [i]
is -> i : concatMap (allExtends gr) is
_ -> []
allExtends gr i =
case lookupModule gr i of
Ok m -> case extends m of
[] -> [i]
is -> i : concatMap (allExtends gr) is
_ -> []
-- | all modules that a module extends, directly or indirectly, with restricts
allExtendSpecs :: (Show i,Ord i) => MGrammar i a -> i -> [(i,MInclude i)]
allExtendSpecs gr i = case lookupModule gr i of
Ok (ModMod m) -> case extend m of
[] -> [(i,MIAll)]
is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is
_ -> []
allExtendSpecs gr i =
case lookupModule gr i of
Ok m -> case extend m of
[] -> [(i,MIAll)]
is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is
_ -> []
-- | this plus that an instance extends its interface
allExtendsPlus :: (Show i,Ord i) => MGrammar i a -> i -> [i]
allExtendsPlus gr i = case lookupModule gr i of
Ok (ModMod m) -> i : concatMap (allExtendsPlus gr) (exts m)
_ -> []
where
exts m = extends m ++ [j | MTInstance j <- [mtype m]]
allExtendsPlus gr i =
case lookupModule gr i of
Ok m -> i : concatMap (allExtendsPlus gr) (exts m)
_ -> []
where
exts m = extends m ++ [j | MTInstance j <- [mtype m]]
-- | conversely: all modules that extend a given module, incl. instances of interface
allExtensions :: (Show i,Ord i) => MGrammar i a -> i -> [i]
allExtensions gr i = case lookupModule gr i of
Ok (ModMod m) -> let es = exts i in es ++ concatMap (allExtensions gr) es
_ -> []
allExtensions gr i =
case lookupModule gr i of
Ok m -> let es = exts i in es ++ concatMap (allExtensions gr) es
_ -> []
where
exts i = [j | (j,m) <- mods, elem i (extends m)
|| elem (MTInstance i) [mtype m]]
mods = [(j,m) | (j,ModMod m) <- modules gr]
mods = modules gr
-- | initial search path: the nonqualified dependencies
searchPathModule :: Ord i => Module i a -> [i]
searchPathModule m = [i | OSimple _ i <- depPathModule m]
searchPathModule :: Ord i => ModInfo i a -> [i]
searchPathModule m = [i | OSimple i <- depPathModule m]
-- | a new module can safely be added to the end, since nothing old can depend on it
addModule :: Ord i =>
@@ -269,11 +225,7 @@ emptyMGrammar :: MGrammar i a
emptyMGrammar = MGrammar []
emptyModInfo :: ModInfo i a
emptyModInfo = ModMod emptyModule
emptyModule :: Module i a
emptyModule = Module
MTResource MSComplete noOptions [] [] emptyBinTree emptyBinTree
emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] emptyBinTree emptyBinTree
-- | we store the module type with the identifier
data IdentM i = IdentM {
@@ -282,27 +234,18 @@ data IdentM i = IdentM {
}
deriving (Eq,Ord,Show)
typeOfModule :: ModInfo i a -> ModuleType i
typeOfModule mi = case mi of
ModMod m -> mtype m
abstractOfConcrete :: (Show i, Eq i) => MGrammar i a -> i -> Err i
abstractOfConcrete gr c = do
m <- lookupModule gr c
case m of
ModMod n -> case mtype n of
MTConcrete a -> return a
_ -> Bad $ "expected concrete" +++ show c
n <- lookupModule gr c
case mtype n of
MTConcrete a -> return a
_ -> Bad $ "expected concrete" +++ show c
abstractModOfConcrete :: (Show i, Eq i) =>
MGrammar i a -> i -> Err (Module i a)
MGrammar i a -> i -> Err (ModInfo i a)
abstractModOfConcrete gr c = do
a <- abstractOfConcrete gr c
m <- lookupModule gr a
case m of
ModMod n -> return n
_ -> Bad $ "expected abstract" +++ show c
lookupModule gr a
-- the canonical file name
@@ -318,56 +261,41 @@ lookupModule gr m = case lookup m (modules gr) of
lookupModuleType :: (Show i,Eq i) => MGrammar i a -> i -> Err (ModuleType i)
lookupModuleType gr m = do
mi <- lookupModule gr m
return $ typeOfModule mi
return $ mtype mi
lookupModMod :: (Show i,Eq i) => MGrammar i a -> i -> Err (Module i a)
lookupModMod gr i = do
mo <- lookupModule gr i
case mo of
ModMod m -> return m
_ -> Bad $ "expected proper module, not" +++ show i
lookupInfo :: (Show i, Ord i) => Module i a -> i -> Err a
lookupInfo :: (Show i, Ord i) => ModInfo i a -> i -> Err a
lookupInfo mo i = lookupTree show i (jments mo)
lookupPosition :: (Show i, Ord i) => Module i a -> i -> Err (String,(Int,Int))
lookupPosition :: (Show i, Ord i) => ModInfo i a -> i -> Err (String,(Int,Int))
lookupPosition mo i = lookupTree show i (positions mo)
showPosition :: (Show i, Ord i) => Module i a -> i -> String
showPosition :: (Show i, Ord i) => ModInfo i a -> i -> String
showPosition mo i = case lookupPosition mo i of
Ok (f,(b,e)) | b == e -> "in" +++ f ++ ", line" +++ show b
Ok (f,(b,e)) -> "in" +++ f ++ ", lines" +++ show b ++ "-" ++ show e
_ -> ""
allModMod :: (Show i,Eq i) => MGrammar i a -> [(i,Module i a)]
allModMod gr = [(i,m) | (i, ModMod m) <- modules gr]
isModAbs :: Module i a -> Bool
isModAbs :: ModInfo i a -> Bool
isModAbs m = case mtype m of
MTAbstract -> True
---- MTUnion t -> isModAbs t
_ -> False
isModRes :: Module i a -> Bool
isModRes :: ModInfo i a -> Bool
isModRes m = case mtype m of
MTResource -> True
MTReuse _ -> True
---- MTUnion t -> isModRes t --- maybe not needed, since eliminated early
MTInterface -> True ---
MTInstance _ -> True
_ -> False
isModCnc :: Module i a -> Bool
isModCnc :: ModInfo i a -> Bool
isModCnc m = case mtype m of
MTConcrete _ -> True
---- MTUnion t -> isModCnc t
_ -> False
isModTrans :: Module i a -> Bool
isModTrans :: ModInfo i a -> Bool
isModTrans m = case mtype m of
MTTransfer _ _ -> True
---- MTUnion t -> isModTrans t
_ -> False
sameMType :: Eq i => ModuleType i -> ModuleType i -> Bool
@@ -390,21 +318,20 @@ sameMType m n = case (n,m) of
-- | don't generate code for interfaces and for incomplete modules
isCompilableModule :: ModInfo i a -> Bool
isCompilableModule m = case m of
ModMod m -> case mtype m of
isCompilableModule m =
case mtype m of
MTInterface -> False
_ -> mstatus m == MSComplete
_ -> False ---
_ -> mstatus m == MSComplete
-- | interface and "incomplete M" are not complete
isCompleteModule :: (Eq i) => Module i a -> Bool
isCompleteModule :: (Eq i) => ModInfo i a -> Bool
isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
-- | all abstract modules sorted from least to most dependent
allAbstracts :: (Ord i, Show i) => MGrammar i a -> [i]
allAbstracts gr =
case topoTest [(i,extends m) | (i,ModMod m) <- modules gr, mtype m == MTAbstract] of
case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
Left is -> is
Right cycles -> error $ "Cyclic abstract modules: " ++ show cycles
@@ -416,7 +343,7 @@ greatestAbstract gr = case allAbstracts gr of
-- | all resource modules
allResources :: MGrammar i a -> [i]
allResources gr = [i | (i,ModMod m) <- modules gr, isModRes m || isModCnc m]
allResources gr = [i | (i,m) <- modules gr, isModRes m || isModCnc m]
-- | the greatest resource in dependency order
greatestResource :: MGrammar i a -> Maybe i
@@ -427,9 +354,9 @@ greatestResource gr = case allResources gr of
-- | all concretes for a given abstract
allConcretes :: Eq i => MGrammar i a -> i -> [i]
allConcretes gr a =
[i | (i, ModMod m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
[i | (i, m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
-- | all concrete modules for any abstract
allConcreteModules :: Eq i => MGrammar i a -> [i]
allConcreteModules gr =
[i | (i, ModMod m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
[i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]

4
src/GF/Source/CF.hs
View File

@@ -81,8 +81,8 @@ type CFFun = String
cf2gf :: String -> CF -> SourceGrammar
cf2gf name cf = MGrammar [
(aname, ModMod (emptyModule {mtype = MTAbstract, jments = abs})),
(cname, ModMod (emptyModule {mtype = MTConcrete aname, jments = cnc}))
(aname, emptyModInfo{mtype = MTAbstract, jments = abs}),
(cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc})
]
where
(abs,cnc) = cf2grammar cf

19
src/GF/Source/GrammarToSource.hs
View File

@@ -35,13 +35,13 @@ trGrammar :: SourceGrammar -> P.Grammar
trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes
trModule :: (Ident,SourceModInfo) -> P.ModDef
trModule (i,mo) = case mo of
ModMod m -> P.MModule compl typ body where
trModule (i,m) = P.MModule compl typ body
where
compl = case mstatus m of
MSIncomplete -> P.CMIncompl
_ -> P.CMCompl
i' = tri i
typ = case typeOfModule mo of
typ = case mtype m of
MTResource -> P.MTResource i'
MTAbstract -> P.MTAbstract i'
MTConcrete a -> P.MTConcrete i' (tri a)
@@ -66,15 +66,8 @@ forName (MTConcrete a) = tri a
trOpen :: OpenSpec Ident -> P.Open
trOpen o = case o of
OSimple OQNormal i -> P.OName (tri i)
OSimple q i -> P.OQualQO (trQualOpen q) (tri i)
OQualif q i j -> P.OQual (trQualOpen q) (tri i) (tri j)
trQualOpen q = case q of
OQNormal -> P.QOCompl
OQIncomplete -> P.QOIncompl
OQInterface -> P.QOInterface
OSimple i -> P.OName (tri i)
OQualif i j -> P.OQual P.QOCompl (tri i) (tri j)
mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds
mkTopDefs ds = ds
@@ -87,8 +80,6 @@ trAnyDef (i,info) = let i' = tri i in case info of
Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]]
_ -> []
AbsFun (May b) _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]]
---- don't destroy definitions!
AbsTrans f -> [P.DefTrans [P.DDef [mkName i'] (trt f)]]
ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
ResParam pp -> [P.DefPar [case pp of

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

@@ -70,15 +70,9 @@ transGrammar x = case x of
moddefs' <- mapM transModDef moddefs
GD.mkSourceGrammar moddefs'
transModDef :: ModDef -> Err (Ident, G.SourceModInfo)
transModDef :: ModDef -> Err G.SourceModule
transModDef x = case x of
MMain id0 id concspecs -> do
id0' <- transIdent id0
id' <- transIdent id
concspecs' <- mapM transConcSpec concspecs
return $ (id0', GM.ModMainGrammar (GM.MainGrammar id' concspecs'))
MModule compl mtyp body -> do
let mstat' = transComplMod compl
@@ -117,14 +111,7 @@ transModDef x = case x of
defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatOptions [o | Right o <- defs0]
let poss1 = buildPosTree id' poss0
return (id',
GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1))
MReuse _ -> do
return (id', GM.ModMod (GM.Module mtyp' mstat' noOptions [] [] emptyBinTree poss))
MUnion imps -> do
imps' <- mapM transIncluded imps
return (id',
GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' noOptions [] [] emptyBinTree poss))
return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' defs' poss1)
MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
@@ -139,21 +126,11 @@ transModDef x = case x of
defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatOptions [o | Right o <- defs0]
let poss1 = buildPosTree id' poss0
return (id',
GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1) m' insts')
return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' defs' poss1)
mkModRes id mtyp body = do
id' <- transIdent id
case body of
MReuse c -> do
c' <- transIdent c
mtyp' <- trMReuseType mtyp c'
return (transResDef, GM.MTReuse mtyp', id')
_ -> return (transResDef, mtyp, id')
trMReuseType mtyp c = case mtyp of
GM.MTInterface -> return $ GM.MRInterface c
GM.MTInstance op -> return $ GM.MRInstance c op
GM.MTResource -> return $ GM.MRResource c
return (transResDef, mtyp, id')
transComplMod :: ComplMod -> GM.ModuleStatus
@@ -164,13 +141,6 @@ transComplMod x = case x of
getTopDefs :: [TopDef] -> [TopDef]
getTopDefs x = x
transConcSpec :: ConcSpec -> Err (GM.MainConcreteSpec Ident)
transConcSpec x = case x of
ConcSpec id concexp -> do
id' <- transIdent id
(m,mi,mo) <- transConcExp concexp
return $ GM.MainConcreteSpec id' m mi mo
transConcExp :: ConcExp ->
Err (Ident, Maybe (GM.OpenSpec Ident),Maybe (GM.OpenSpec Ident))
transConcExp x = case x of
@@ -205,15 +175,9 @@ transOpens x = case x of
transOpen :: Open -> Err (GM.OpenSpec Ident)
transOpen x = case x of
OName id -> liftM (GM.OSimple GM.OQNormal) $ transIdent id
OQualQO q id -> liftM2 GM.OSimple (transQualOpen q) (transIdent id)
OQual q id m -> liftM3 GM.OQualif (transQualOpen q) (transIdent id) (transIdent m)
transQualOpen :: QualOpen -> Err GM.OpenQualif
transQualOpen x = case x of
QOCompl -> return GM.OQNormal
QOInterface -> return GM.OQInterface
QOIncompl -> return GM.OQIncomplete
OName id -> liftM GM.OSimple (transIdent id)
OQualQO q id -> liftM GM.OSimple (transIdent id)
OQual q id m -> liftM2 GM.OQualif (transIdent id) (transIdent m)
transIncluded :: Included -> Err (Ident,[Ident])
transIncluded x = case x of
@@ -261,9 +225,6 @@ transAbsDef x = case x of
returnl $
[(c, nopos, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++
[(f, nopos, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf]
DefTrans defs -> do
defs' <- liftM concat $ mapM getDefsGen defs
returnl [(c, nopos, G.AbsTrans f) | ((c,p),(_,Yes f)) <- defs']
DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs
_ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
where

2
src/exper/Evaluate.hs
View File

@@ -386,7 +386,7 @@ evalConcrete gr mo = mapMTree evaldef mo where
Bad s -> raise s
noExpand p = errVal False $ do
mo <- lookupModMod gr p
mo <- lookupModule gr p
return $ case getOptVal (iOpts (flags mo)) useOptimizer of
Just "noexpand" -> True
_ -> False

15
src/exper/Optimize.hs
View File

@@ -37,10 +37,10 @@ import Data.List
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
-- only do this for resource: concrete is optimized in gfc form
optimizeModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) ->
Err (Ident,SourceModInfo)
optimizeModule :: Options -> [(Ident,SourceModule)] -> (Ident,SourceModule) ->
Err (Ident,SourceModule)
optimizeModule opts ms mo@(_,mi) = case mi of
ModMod m0@(Module mt st fs me ops js) | st == MSComplete && isModRes m0 -> do
m0@(Module mt st fs me ops js) | st == MSComplete && isModRes m0 -> do
mo1 <- evalModule oopts ms mo
return $ case optim of
"parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing
@@ -54,11 +54,10 @@ optimizeModule opts ms mo@(_,mi) = case mi of
oopts = addOptions opts (iOpts (flagsModule mo))
optim = maybe "all" id $ getOptVal oopts useOptimizer
evalModule :: Options -> [(Ident,SourceModInfo)] -> (Ident,SourceModInfo) ->
Err (Ident,SourceModInfo)
evalModule :: Options -> [(Ident,SourceModule)] -> (Ident,SourceModule) -> Err (Ident,SourceModule)
evalModule oopts ms mo@(name,mod) = case mod of
ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
{-
-- now: don't optimize resource
@@ -72,7 +71,7 @@ evalModule oopts ms mo@(name,mod) = case mod of
-----
js0 <- appEvalConcrete gr js
js' <- mapMTree (evalCncInfo oopts gr name a) js0 ---- <- gr0 6/12/2005
return $ (name, ModMod (Module mt st fs me ops js'))
return $ (name, Module mt st fs me ops js')
_ -> return $ (name,mod)
_ -> return $ (name,mod)
@@ -80,7 +79,7 @@ evalModule oopts ms mo@(name,mod) = case mod of
gr0 = MGrammar $ ms
gr = MGrammar $ (name,mod) : ms
evalOp g@(MGrammar ((_, ModMod m) : _)) i = do
evalOp g@(MGrammar ((_, m) : _)) i = do
info <- lookupTree prt i $ jments m
info' <- evalResInfo oopts gr (i,info)
return $ updateRes g name i info'