summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorkrasimir <krasimir@chalmers.se>2009-01-19 13:23:03 +0000
committerkrasimir <krasimir@chalmers.se>2009-01-19 13:23:03 +0000
commitd95ca4a103c9023aa104b25acdc9c21418de6a14 (patch)
tree7cff6e45e2dc1ba08deb503589e21770c7f239b3 /src
parentfa7ab84471652c40079e4f77d242208376c4b668 (diff)
refactor the GF.Grammar.Grammar syntax. The obsolete constructions are removed
Diffstat (limited to 'src')
-rw-r--r--src/GF/Compile.hs10
-rw-r--r--src/GF/Compile/BackOpt.hs7
-rw-r--r--src/GF/Compile/CheckGrammar.hs34
-rw-r--r--src/GF/Compile/Coding.hs15
-rw-r--r--src/GF/Compile/Extend.hs13
-rw-r--r--src/GF/Compile/GrammarToGFCC.hs30
-rw-r--r--src/GF/Compile/ModDeps.hs25
-rw-r--r--src/GF/Compile/Optimize.hs46
-rw-r--r--src/GF/Compile/OptimizeGF.hs37
-rw-r--r--src/GF/Compile/Rebuild.hs25
-rw-r--r--src/GF/Compile/Refresh.hs8
-rw-r--r--src/GF/Compile/RemoveLiT.hs15
-rw-r--r--src/GF/Compile/Rename.hs55
-rw-r--r--src/GF/Compile/Update.hs8
-rw-r--r--src/GF/Grammar/Grammar.hs12
-rw-r--r--src/GF/Grammar/LookAbs.hs30
-rw-r--r--src/GF/Grammar/Lookup.hs149
-rw-r--r--src/GF/Grammar/PrGrammar.hs6
-rw-r--r--src/GF/Infra/Dependencies.hs2
-rw-r--r--src/GF/Infra/Modules.hs253
-rw-r--r--src/GF/Source/CF.hs4
-rw-r--r--src/GF/Source/GrammarToSource.hs19
-rw-r--r--src/GF/Source/SourceToGrammar.hs53
-rw-r--r--src/exper/Evaluate.hs2
-rw-r--r--src/exper/Optimize.hs15
25 files changed, 328 insertions, 545 deletions
diff --git a/src/GF/Compile.hs b/src/GF/Compile.hs
index e7e16013c..e4804bd18 100644
--- a/src/GF/Compile.hs
+++ b/src/GF/Compile.hs
@@ -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
diff --git a/src/GF/Compile/BackOpt.hs b/src/GF/Compile/BackOpt.hs
index aeb3bcb8d..484b1f1f0 100644
--- a/src/GF/Compile/BackOpt.hs
+++ b/src/GF/Compile/BackOpt.hs
@@ -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
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs
index 5b9e6d923..2d93394e3 100644
--- a/src/GF/Compile/CheckGrammar.hs
+++ b/src/GF/Compile/CheckGrammar.hs
@@ -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
diff --git a/src/GF/Compile/Coding.hs b/src/GF/Compile/Coding.hs
index 665b5916d..088f7b8e8 100644
--- a/src/GF/Compile/Coding.hs
+++ b/src/GF/Compile/Coding.hs
@@ -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)
diff --git a/src/GF/Compile/Extend.hs b/src/GF/Compile/Extend.hs
index 8344a1696..4cf2101de 100644
--- a/src/GF/Compile/Extend.hs
+++ b/src/GF/Compile/Extend.hs
@@ -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))
diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs
index 27c732573..81029117d 100644
--- a/src/GF/Compile/GrammarToGFCC.hs
+++ b/src/GF/Compile/GrammarToGFCC.hs
@@ -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
diff --git a/src/GF/Compile/ModDeps.hs b/src/GF/Compile/ModDeps.hs
index b5b1b798c..8bfead11b 100644
--- a/src/GF/Compile/ModDeps.hs
+++ b/src/GF/Compile/ModDeps.hs
@@ -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
diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs
index da18e6e3e..31564d444 100644
--- a/src/GF/Compile/Optimize.hs
+++ b/src/GF/Compile/Optimize.hs
@@ -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
-
- 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, ModMod (replaceJudgements m0 js')),eenv)
-
- _ -> return $ ((name,mod),eenv)
- _ -> return $ ((name,mod),eenv)
+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)
+
+ MTConcrete a -> do
+ js' <- mapMTree (evalCncInfo oopts gr name a) (jments m0)
+ return $ ((name,replaceJudgements m0 js'),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'
diff --git a/src/GF/Compile/OptimizeGF.hs b/src/GF/Compile/OptimizeGF.hs
index 785d73994..27627b137 100644
--- a/src/GF/Compile/OptimizeGF.hs
+++ b/src/GF/Compile/OptimizeGF.hs
@@ -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
diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs
index 04fc43d10..53f1ec0f1 100644
--- a/src/GF/Compile/Rebuild.hs
+++ b/src/GF/Compile/Rebuild.hs
@@ -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
diff --git a/src/GF/Compile/Refresh.hs b/src/GF/Compile/Refresh.hs
index 39fb57db0..d446008d0 100644
--- a/src/GF/Compile/Refresh.hs
+++ b/src/GF/Compile/Refresh.hs
@@ -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
diff --git a/src/GF/Compile/RemoveLiT.hs b/src/GF/Compile/RemoveLiT.hs
index a641737eb..14a9a1da1 100644
--- a/src/GF/Compile/RemoveLiT.hs
+++ b/src/GF/Compile/RemoveLiT.hs
@@ -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
diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs
index bfa342702..ba14cb02e 100644
--- a/src/GF/Compile/Rename.hs
+++ b/src/GF/Compile/Rename.hs
@@ -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 ->
diff --git a/src/GF/Compile/Update.hs b/src/GF/Compile/Update.hs
index 82d7a609e..a0aefeea5 100644
--- a/src/GF/Compile/Update.hs
+++ b/src/GF/Compile/Update.hs
@@ -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)
diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs
index a3735c32f..c1ec709f3 100644
--- a/src/GF/Grammar/Grammar.hs
+++ b/src/GF/Grammar/Grammar.hs
@@ -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/)
diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs
index f9a251eb1..137e602aa 100644
--- a/src/GF/Grammar/LookAbs.hs
+++ b/src/GF/Grammar/LookAbs.hs
@@ -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
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
index 4a11a0d3f..1dcb47a21 100644
--- a/src/GF/Grammar/Lookup.hs
+++ b/src/GF/Grammar/Lookup.hs
@@ -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
-
- -- used in reused concrete
- CncCat _ _ _ -> return typeType
- CncFun (Just (cat,(cont@(_:_),val))) _ _ -> do
+ 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
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],
diff --git a/src/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs
index df8c014c7..e359d360b 100644
--- a/src/GF/Grammar/PrGrammar.hs
+++ b/src/GF/Grammar/PrGrammar.hs
@@ -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
diff --git a/src/GF/Infra/Dependencies.hs b/src/GF/Infra/Dependencies.hs
index 084cfce1c..1eff523b8 100644
--- a/src/GF/Infra/Dependencies.hs
+++ b/src/GF/Infra/Dependencies.hs
@@ -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
diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs
index fc319f6b3..56cfb8063 100644
--- a/src/GF/Infra/Modules.hs
+++ b/src/GF/Infra/Modules.hs
@@ -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]
-
-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
+allFlags gr = concatOptions [flags m | (_,m) <- modules gr]
-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
-
-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
+ return $ mtype mi
-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]
diff --git a/src/GF/Source/CF.hs b/src/GF/Source/CF.hs
index b268a8ecd..ae42958b6 100644
--- a/src/GF/Source/CF.hs
+++ b/src/GF/Source/CF.hs
@@ -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
diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs
index 73b0feafd..d16d75971 100644
--- a/src/GF/Source/GrammarToSource.hs
+++ b/src/GF/Source/GrammarToSource.hs
@@ -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
diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs
index da5ab180d..61912704b 100644
--- a/src/GF/Source/SourceToGrammar.hs
+++ b/src/GF/Source/SourceToGrammar.hs
@@ -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
diff --git a/src/exper/Evaluate.hs b/src/exper/Evaluate.hs
index 7c5fb4b6a..413c82402 100644
--- a/src/exper/Evaluate.hs
+++ b/src/exper/Evaluate.hs
@@ -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
diff --git a/src/exper/Optimize.hs b/src/exper/Optimize.hs
index 93346bc70..7cf88554f 100644
--- a/src/exper/Optimize.hs
+++ b/src/exper/Optimize.hs
@@ -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'