summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorkr.angelov <kr.angelov@gmail.com>2011-11-02 13:57:11 +0000
committerkr.angelov <kr.angelov@gmail.com>2011-11-02 13:57:11 +0000
commit734c66710e9bffa986c094e8c584295b33cd2f63 (patch)
tree73fb499ba17a3d6d8986784f4a17ad03420204e4 /src
parent5fe49ed9f7ac7089301e867e55bfedefcba230dd (diff)
merge GF.Infra.Modules and GF.Grammar.Grammar. This is a preparation for the separate PGF building
Diffstat (limited to 'src')
-rw-r--r--src/compiler/GF/Compile.hs7
-rw-r--r--src/compiler/GF/Compile/CheckGrammar.hs7
-rw-r--r--src/compiler/GF/Compile/Coding.hs3
-rw-r--r--src/compiler/GF/Compile/Compute/AppPredefined.hs1
-rw-r--r--src/compiler/GF/Compile/Compute/ConcreteLazy.hs1
-rw-r--r--src/compiler/GF/Compile/GeneratePMCFG.hs13
-rw-r--r--src/compiler/GF/Compile/GetGrammar.hs15
-rw-r--r--src/compiler/GF/Compile/GrammarToPGF.hs23
-rw-r--r--src/compiler/GF/Compile/ModDeps.hs10
-rw-r--r--src/compiler/GF/Compile/Optimize.hs7
-rw-r--r--src/compiler/GF/Compile/ReadFiles.hs5
-rw-r--r--src/compiler/GF/Compile/Refresh.hs3
-rw-r--r--src/compiler/GF/Compile/Rename.hs5
-rw-r--r--src/compiler/GF/Compile/SubExOpt.hs11
-rw-r--r--src/compiler/GF/Compile/TypeCheck/Concrete.hs1
-rw-r--r--src/compiler/GF/Compile/Update.hs9
-rw-r--r--src/compiler/GF/Grammar/Analyse.hs1
-rw-r--r--src/compiler/GF/Grammar/Binary.hs7
-rw-r--r--src/compiler/GF/Grammar/CF.hs6
-rw-r--r--src/compiler/GF/Grammar/Grammar.hs273
-rw-r--r--src/compiler/GF/Grammar/Lookup.hs6
-rw-r--r--src/compiler/GF/Grammar/Macros.hs3
-rw-r--r--src/compiler/GF/Grammar/Parser.y1
-rw-r--r--src/compiler/GF/Grammar/Printer.hs1
-rw-r--r--src/compiler/GF/Infra/Dependencies.hs5
-rw-r--r--src/compiler/GF/Infra/Modules.hs340
-rw-r--r--src/compiler/GF/Speech/VoiceXML.hs1
-rw-r--r--src/compiler/GFI.hs6
-rw-r--r--src/compiler/GFTags.hs1
29 files changed, 322 insertions, 450 deletions
diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs
index 5b3abb98c..c737480e1 100644
--- a/src/compiler/GF/Compile.hs
+++ b/src/compiler/GF/Compile.hs
@@ -20,7 +20,6 @@ import GF.Grammar.Binary
import GF.Infra.Ident
import GF.Infra.Option
-import GF.Infra.Modules
import GF.Infra.UseIO
import GF.Infra.CheckM
@@ -139,7 +138,7 @@ compileOne opts env@(_,srcgr,_) file = do
-- also undo common subexp optimization, to enable normal computations
".gfo" -> do
sm00 <- putPointE Verbose opts ("+ reading" +++ file) $ ioeIO (decodeFile file)
- let sm0 = addOptionsToModule opts sm00
+ let sm0 = (fst sm00, (snd sm00) {mflags = mflags (snd sm00) `addOptions` opts})
intermOut opts DumpSource (ppModule Qualified sm0)
@@ -159,7 +158,7 @@ compileOne opts env@(_,srcgr,_) file = do
sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $
getSourceModule opts file
- enc <- ioeIO $ mkTextEncoding (renameEncoding (flag optEncoding (flagsModule sm00)))
+ enc <- ioeIO $ mkTextEncoding (renameEncoding (flag optEncoding (mflags (snd sm00))))
let sm = decodeStringsInModule enc sm00
intermOut opts DumpSource (ppModule Qualified sm)
@@ -229,7 +228,7 @@ generateModuleCode opts file minfo = do
--reverseModules (MGrammar ms) = MGrammar $ reverse ms
emptyCompileEnv :: CompileEnv
-emptyCompileEnv = (0,emptyMGrammar,Map.empty)
+emptyCompileEnv = (0,emptySourceGrammar,Map.empty)
extendCompileEnvInt (_,gr,menv) k mfile sm = do
let (mod,imps) = importsOfModule sm
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index 44e2e552b..2b82bc781 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -23,7 +23,6 @@
module GF.Compile.CheckGrammar(checkModule) where
import GF.Infra.Ident
-import GF.Infra.Modules
import GF.Compile.TypeCheck.Abstract
import GF.Compile.TypeCheck.Concrete
@@ -56,13 +55,13 @@ checkModule ms m@(name,mo) = checkIn (text "checking module" <+> ppIdent name) $
where
updateCheckInfo (name,mo) (i,info) = do
info <- checkInfo ms (name,mo) i info
- return (name,updateModule mo i info)
+ return (name,mo{jments=updateTree (i,info) (jments mo)})
-- 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 mos (name,mo) = do
- let irs = [ii | ii@(_,mi) <- extend mo, mi /= MIAll] -- names with restr. inh.
+ let irs = [ii | ii@(_,mi) <- mextend mo, mi /= MIAll] -- names with restr. inh.
let mrs = [((i,m),mi) | (i,m) <- mos, Just mi <- [lookup i irs]]
-- the restr. modules themself, with restr. infos
mapM_ checkRem mrs
@@ -90,7 +89,7 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
-- check that all abstract constants are in concrete; build default lin and lincats
jsc <- foldM checkAbs jsc (tree2list jsa)
- return (cm,replaceJudgements cnc jsc)
+ return (cm,cnc{jments=jsc})
where
checkAbs js i@(c,info) =
case info of
diff --git a/src/compiler/GF/Compile/Coding.hs b/src/compiler/GF/Compile/Coding.hs
index e7c90b850..1b8753afe 100644
--- a/src/compiler/GF/Compile/Coding.hs
+++ b/src/compiler/GF/Compile/Coding.hs
@@ -3,7 +3,6 @@ module GF.Compile.Coding where
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Text.Coding
-import GF.Infra.Modules
import GF.Infra.Option
import GF.Data.Operations
@@ -18,7 +17,7 @@ decodeStringsInModule :: TextEncoding -> SourceModule -> SourceModule
decodeStringsInModule enc mo = codeSourceModule (decodeUnicode enc . BS.pack) mo
codeSourceModule :: (String -> String) -> SourceModule -> SourceModule
-codeSourceModule co (id,mo) = (id,replaceJudgements mo (mapTree codj (jments mo)))
+codeSourceModule co (id,mo) = (id,mo{jments = mapTree codj (jments mo)})
where
codj (c,info) = case info of
ResOper pty pt -> ResOper (codeLTerms co pty) (codeLTerms co pt)
diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs
index 8732a8e06..af440ba0d 100644
--- a/src/compiler/GF/Compile/Compute/AppPredefined.hs
+++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs
@@ -17,7 +17,6 @@ module GF.Compile.Compute.AppPredefined (
) where
import GF.Infra.Ident
-import GF.Infra.Modules
import GF.Infra.Option
import GF.Data.Operations
import GF.Grammar
diff --git a/src/compiler/GF/Compile/Compute/ConcreteLazy.hs b/src/compiler/GF/Compile/Compute/ConcreteLazy.hs
index c120ab03a..c5bdc8a75 100644
--- a/src/compiler/GF/Compile/Compute/ConcreteLazy.hs
+++ b/src/compiler/GF/Compile/Compute/ConcreteLazy.hs
@@ -18,7 +18,6 @@ import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Option
-import GF.Infra.Modules
import GF.Data.Str
import GF.Grammar.ShowTerm
import GF.Grammar.Printer
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index a3406dd0e..aaa4a2961 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -17,7 +17,6 @@ import PGF.Data hiding (Type)
import GF.Infra.Option
import GF.Grammar hiding (Env, mkRecord, mkTable)
-import qualified GF.Infra.Modules as M
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Data.BacktrackM
@@ -53,21 +52,21 @@ convertConcrete opts0 gr am cm = do
where
(m,mo) = cm
- opts = addOptions (M.flags (snd am)) opts0
+ opts = addOptions (mflags (snd am)) opts0
pflindefs = [
((m,id),term,lincat) |
- (id,GF.Grammar.CncCat (Just (L _ lincat)) (Just (L _ term)) _) <- Map.toList (M.jments mo)]
+ (id,GF.Grammar.CncCat (Just (L _ lincat)) (Just (L _ term)) _) <- Map.toList (jments mo)]
pfrules = [
(PFRule id args ([],res) (map (\(_,_,ty) -> ty) cont) val term) |
- (id,GF.Grammar.CncFun (Just (cat,cont,val)) (Just (L _ term)) _) <- Map.toList (M.jments mo),
+ (id,GF.Grammar.CncFun (Just (cat,cont,val)) (Just (L _ term)) _) <- Map.toList (jments mo),
let (ctxt,res,_) = err error typeForm (lookupFunType gr (fst am) id)
args = [catSkeleton ty | (_,_,ty) <- ctxt]]
- flags = Map.fromList [(mkCId f,LStr x) | (f,x) <- optionsPGF (M.flags mo)]
+ flags = Map.fromList [(mkCId f,LStr x) | (f,x) <- optionsPGF (mflags mo)]
- printnames = Map.fromAscList [(i2i id, name) | (id,info) <- Map.toList (M.jments mo), name <- prn info]
+ printnames = Map.fromAscList [(i2i id, name) | (id,info) <- Map.toList (jments mo), name <- prn info]
where
prn (GF.Grammar.CncFun _ _ (Just (L _ tr))) = [flatten tr]
prn (GF.Grammar.CncCat _ _ (Just (L _ tr))) = [flatten tr]
@@ -519,7 +518,7 @@ emptyGrammarEnv gr (m,mo) =
lincats =
Map.insert cVar (Sort cStr) $
Map.fromAscList
- [(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (M.jments mo)]
+ [(c, ty) | (c,GF.Grammar.CncCat (Just (L _ ty)) _ _) <- Map.toList (jments mo)]
addApplication :: GrammarEnv -> FId -> (FunId,[FId]) -> GrammarEnv
addApplication (GrammarEnv last_id catSet seqSet funSet lindefSet crcSet appSet prodSet) fid p =
diff --git a/src/compiler/GF/Compile/GetGrammar.hs b/src/compiler/GF/Compile/GetGrammar.hs
index 339f28578..914a19aac 100644
--- a/src/compiler/GF/Compile/GetGrammar.hs
+++ b/src/compiler/GF/Compile/GetGrammar.hs
@@ -12,12 +12,11 @@
-- this module builds the internal GF grammar that is sent to the type checker
-----------------------------------------------------------------------------
-module GF.Compile.GetGrammar (getSourceModule, addOptionsToModule) where
+module GF.Compile.GetGrammar (getSourceModule) where
import GF.Data.Operations
import GF.Infra.UseIO
-import GF.Infra.Modules
import GF.Infra.Option
import GF.Grammar.Lexer
import GF.Grammar.Parser
@@ -40,16 +39,10 @@ getSourceModule opts file0 = ioe $
Left (Pn l c,msg) -> do file <- writeTemp tmp
let location = file++":"++show l++":"++show c
return (Bad (location++": "++msg))
- Right mo -> do removeTemp tmp
- return (Ok (addOptionsToModule opts (setSrcPath file0 mo)))
+ Right (i,mi) -> do removeTemp tmp
+ return (Ok (i,mi{mflags=mflags mi `addOptions` opts, msrc=file0}))
`catch` (return . Bad . show)
-setSrcPath :: FilePath -> SourceModule -> SourceModule
-setSrcPath fpath = mapSourceModule (\m -> m{msrc=fpath})
-
-addOptionsToModule :: Options -> SourceModule -> SourceModule
-addOptionsToModule opts = mapSourceModule (\m -> m { flags = flags m `addOptions` opts })
-
runPreprocessor :: Temporary -> String -> IO Temporary
runPreprocessor tmp0 p =
maybe external internal (lookup p builtin_preprocessors)
@@ -100,4 +93,4 @@ keepTemp tmp =
Internal str -> return str
removeTemp (Temp path) = removeFile path
-removeTemp _ = return () \ No newline at end of file
+removeTemp _ = return ()
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index 81d2b3632..06ececb3c 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -16,7 +16,6 @@ import qualified GF.Grammar.Lookup as Look
import qualified GF.Grammar as A
import qualified GF.Grammar.Macros as GM
--import qualified GF.Compile.Compute.Concrete as Compute ----
-import qualified GF.Infra.Modules as M
import qualified GF.Infra.Option as O
import GF.Infra.Ident
@@ -40,7 +39,7 @@ traceD s t = t
mkCanon2pgf :: Options -> Ident -> SourceGrammar -> IO D.PGF
mkCanon2pgf opts cnc gr = (canon2pgf opts gr . reorder abs) gr
where
- abs = err (const cnc) id $ M.abstractOfConcrete gr cnc
+ abs = err (const cnc) id $ abstractOfConcrete gr cnc
-- Generate PGF from grammar.
@@ -58,17 +57,17 @@ canon2pgf opts gr (am,cms) = do
where
mkAbstr (a,abm) = return (i2i a, D.Abstr flags funs cats)
where
- flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)]
+ flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (mflags abm)]
funs = Map.fromAscList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0)) |
- (f,AbsFun (Just (L _ ty)) ma pty _) <- Map.toAscList (M.jments abm)]
+ (f,AbsFun (Just (L _ ty)) ma pty _) <- Map.toAscList (jments abm)]
cats = Map.fromAscList [(i2i c, (snd (mkContext [] cont),catfuns c)) |
- (c,AbsCat (Just (L _ cont))) <- Map.toAscList (M.jments abm)]
+ (c,AbsCat (Just (L _ cont))) <- Map.toAscList (jments abm)]
catfuns cat =
(map (\x -> (0,snd x)) . sortBy (compare `on` fst))
- [(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _ (Just True)) <- tree2list (M.jments abm), snd (GM.valCat ty) == cat]
+ [(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _ (Just True)) <- tree2list (jments abm), snd (GM.valCat ty) == cat]
mkConcr am cm@(lang,mo) = do
cnc <- convertConcrete opts gr am cm
@@ -154,12 +153,12 @@ compilePatt eqs = whilePP eqs Map.empty
reorder :: Ident -> SourceGrammar -> AbsConcsGrammar
reorder abs cg =
-- M.MGrammar $
- ((abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] "" adefs),
- [(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] "" cdefs)
- | cnc <- M.allConcretes cg abs, let (cflags,cdefs) = concr cnc])
+ ((abs, ModInfo MTAbstract MSComplete aflags [] Nothing [] [] "" adefs),
+ [(cnc, ModInfo (MTConcrete abs) MSComplete cflags [] Nothing [] [] "" cdefs)
+ | cnc <- allConcretes cg abs, let (cflags,cdefs) = concr cnc])
where
aflags =
- concatOptions (reverse [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo])
+ concatOptions (reverse [mflags mo | (_,mo) <- modules cg, isModAbs mo])
adefs =
Map.fromList (predefADefs ++ Look.allOrigInfos cg abs)
@@ -169,8 +168,8 @@ reorder abs cg =
concr la = (flags, Map.fromList (predefCDefs ++ jments))
where
- flags = concatOptions [M.flags mo | (i,mo) <- M.modules cg, M.isModCnc mo,
- Just r <- [lookup i (M.allExtendSpecs cg la)]]
+ flags = concatOptions [mflags mo | (i,mo) <- modules cg, isModCnc mo,
+ Just r <- [lookup i (allExtendSpecs cg la)]]
jments = Look.allOrigInfos cg la
predefCDefs =
[(c, CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
diff --git a/src/compiler/GF/Compile/ModDeps.hs b/src/compiler/GF/Compile/ModDeps.hs
index 1e689aabc..71d428290 100644
--- a/src/compiler/GF/Compile/ModDeps.hs
+++ b/src/compiler/GF/Compile/ModDeps.hs
@@ -68,17 +68,15 @@ moduleDeps :: [SourceModule] -> Err Dependencies
moduleDeps ms = mapM deps ms where
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"
+ am <- lookupModuleType gr a
+ testErr (mtype am == MTAbstract) "the of-module is not an abstract syntax"
chDep (IdentM c (MTConcrete a))
(extends m) (MTConcrete a) (opens m) MTResource
t -> chDep (IdentM c t) (extends m) t (opens m) t
chDep it es ety os oty = do
- ests <- mapM (lookupModuleType gr) es
- testErr (all (compatMType ety) ests) "inappropriate extension module type"
----- osts <- mapM (lookupModuleType gr . openedModule) os
----- testErr (all (compatOType oty) osts) "inappropriate open module type"
+ ems <- mapM (lookupModuleType gr) es
+ testErr (all (compatMType ety . mtype) ests) "inappropriate extension module type"
let ab = case it of
IdentM _ (MTConcrete a) -> [IdentM a MTAbstract]
_ -> [] ----
diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs
index 95ee460ef..303bdb8d0 100644
--- a/src/compiler/GF/Compile/Optimize.hs
+++ b/src/compiler/GF/Compile/Optimize.hs
@@ -17,7 +17,6 @@ module GF.Compile.Optimize (optimizeModule) where
import GF.Grammar.Grammar
import GF.Infra.Ident
-import GF.Infra.Modules
import GF.Grammar.Printer
import GF.Grammar.Macros
import GF.Grammar.Lookup
@@ -49,11 +48,11 @@ optimizeModule opts ms m@(name,mi)
return (name,mi)
| otherwise = return m
where
- oopts = opts `addOptions` flagsModule m
+ oopts = opts `addOptions` mflags mi
updateEvalInfo mi (i,info) = do
- info' <- evalInfo oopts ms (name,mi) i info
- return (updateModule mi i info')
+ info <- evalInfo oopts ms (name,mi) i info
+ return (mi{jments=updateTree (i,info) (jments mi)})
evalInfo :: Options -> [SourceModule] -> SourceModule -> Ident -> Info -> Err Info
evalInfo opts ms m c info = do
diff --git a/src/compiler/GF/Compile/ReadFiles.hs b/src/compiler/GF/Compile/ReadFiles.hs
index 68f16a5d8..5c3ac660d 100644
--- a/src/compiler/GF/Compile/ReadFiles.hs
+++ b/src/compiler/GF/Compile/ReadFiles.hs
@@ -26,7 +26,6 @@ module GF.Compile.ReadFiles
import GF.Infra.UseIO
import GF.Infra.Option
import GF.Infra.Ident
-import GF.Infra.Modules
import GF.Data.Operations
import GF.Grammar.Lexer
import GF.Grammar.Parser
@@ -169,10 +168,10 @@ importsOfModule (m,mi) = (modName m,depModInfo mi [])
where
depModInfo mi =
depModType (mtype mi) .
- depExtends (extend mi) .
+ depExtends (mextend mi) .
depWith (mwith mi) .
depExDeps (mexdeps mi).
- depOpens (opens mi)
+ depOpens (mopens mi)
depModType (MTAbstract) xs = xs
depModType (MTResource) xs = xs
diff --git a/src/compiler/GF/Compile/Refresh.hs b/src/compiler/GF/Compile/Refresh.hs
index 3780db2cf..86e423317 100644
--- a/src/compiler/GF/Compile/Refresh.hs
+++ b/src/compiler/GF/Compile/Refresh.hs
@@ -19,7 +19,6 @@ module GF.Compile.Refresh (refreshTerm, refreshTermN,
import GF.Data.Operations
import GF.Grammar.Grammar
import GF.Infra.Ident
-import GF.Infra.Modules
import GF.Grammar.Macros
import Control.Monad
@@ -114,7 +113,7 @@ refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule]
refreshModule (k,ms) mi@(i,mo)
| isModCnc mo || isModRes mo = do
(k',js') <- foldM refreshRes (k,[]) $ tree2list $ jments mo
- return (k', (i, replaceJudgements mo (buildTree js')) : ms)
+ return (k', (i,mo{jments=buildTree js'}) : ms)
| otherwise = return (k, mi:ms)
where
refreshRes (k,cs) ci@(c,info) = case info of
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index 4c959c194..805e85464 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -31,7 +31,6 @@ module GF.Compile.Rename (
import GF.Grammar.Grammar
import GF.Grammar.Values
import GF.Grammar.Predef
-import GF.Infra.Modules
import GF.Infra.Ident
import GF.Infra.CheckM
import GF.Grammar.Macros
@@ -63,7 +62,7 @@ renameModule :: [SourceModule] -> SourceModule -> Check SourceModule
renameModule ms mo@(m,mi) = checkIn (text "renaming module" <+> ppIdent m) $ do
status <- buildStatus (mGrammar ms) m mi
js <- checkMap (renameInfo status mo) (jments mi)
- return (m, mi{opens = map forceQualif (opens mi), jments = js})
+ return (m, mi{mopens = map forceQualif (mopens mi), jments = js})
type Status = (StatusTree, [(OpenSpec, StatusTree)])
@@ -129,7 +128,7 @@ tree2status o = case o of
buildStatus :: SourceGrammar -> Ident -> SourceModInfo -> Check Status
buildStatus gr c mo = let mo' = self2status c mo in do
let gr1 = prependModule gr (c,mo)
- ops = [OSimple e | e <- allExtends gr1 c] ++ opens mo
+ ops = [OSimple e | e <- allExtends gr1 c] ++ mopens mo
mods <- checkErr $ mapM (lookupModule gr1 . openedModule) ops
let sts = map modInfo2status $ zip ops mods
return $ if isModCnc mo
diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs
index 808e4dca8..453c8e3ca 100644
--- a/src/compiler/GF/Compile/SubExOpt.hs
+++ b/src/compiler/GF/Compile/SubExOpt.hs
@@ -27,7 +27,6 @@ import GF.Grammar.Grammar
import GF.Grammar.Lookup
import GF.Infra.Ident
import qualified GF.Grammar.Macros as C
-import qualified GF.Infra.Modules as M
import GF.Data.Operations
import Control.Monad
@@ -38,17 +37,17 @@ import Data.List
subexpModule :: SourceModule -> SourceModule
subexpModule (n,mo) = errVal (n,mo) $ do
- let ljs = tree2list (M.jments mo)
+ let ljs = tree2list (jments mo)
(tree,_) <- appSTM (getSubtermsMod n ljs) (Map.empty,0)
js2 <- liftM buildTree $ addSubexpConsts n tree $ ljs
- return (n,M.replaceJudgements mo js2)
+ return (n,mo{jments=js2})
unsubexpModule :: SourceModule -> SourceModule
unsubexpModule sm@(i,mo)
- | hasSub ljs = (i,M.replaceJudgements mo (rebuild (map unparInfo ljs)))
+ | hasSub ljs = (i,mo{jments=rebuild (map unparInfo ljs)})
| otherwise = sm
where
- ljs = tree2list (M.jments mo)
+ ljs = tree2list (jments mo)
-- perform this iff the module has opers
hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
@@ -61,7 +60,7 @@ unsubexpModule sm@(i,mo)
Q (m,c) | isOperIdent c -> --- name convention of subexp opers
errVal t $ liftM unparTerm $ lookupResDef gr (m,c)
_ -> C.composSafeOp unparTerm t
- gr = M.mGrammar [sm]
+ gr = mGrammar [sm]
rebuild = buildTree . concat
-- implementation
diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs
index 59d045a4c..bad122db2 100644
--- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs
@@ -2,7 +2,6 @@
module GF.Compile.TypeCheck.Concrete( checkLType, inferLType, computeLType, ppType ) where
import GF.Infra.CheckM
-import GF.Infra.Modules
import GF.Data.Operations
import GF.Grammar
diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs
index fe9bd5984..2a95df4d5 100644
--- a/src/compiler/GF/Compile/Update.hs
+++ b/src/compiler/GF/Compile/Update.hs
@@ -18,7 +18,6 @@ import GF.Infra.Ident
import GF.Grammar.Grammar
import GF.Grammar.Printer
import GF.Grammar.Lookup
-import GF.Infra.Modules
import GF.Infra.Option
import GF.Data.Operations
@@ -50,7 +49,7 @@ extendModule gr (name,m)
---- compiled anyway), extensions are not built for them.
---- Should be replaced by real control. AR 4/2/2005
| mstatus m == MSIncomplete && isModCnc m = return (name,m)
- | otherwise = do m' <- foldM extOne m (extend m)
+ | otherwise = do m' <- foldM extOne m (mextend m)
return (name,m')
where
extOne mo (n,cond) = do
@@ -69,7 +68,7 @@ extendModule gr (name,m)
return $
if isCompl
then mo {jments = js1}
- else mo {extend = filter ((/=n) . fst) (extend mo)
+ else mo {mextend= filter ((/=n) . fst) (mextend mo)
,mexdeps= nub (n : mexdeps mo)
,jments = js1
}
@@ -95,12 +94,12 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ js_)) = do
js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi)
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
case extends mi of
- [] -> return $ replaceJudgements mi js'
+ [] -> return mi{jments=js'}
j0s -> do
m0s <- mapM (lookupModule gr) j0s
let notInM0 c _ = all (not . isInBinTree c . jments) m0s
let js2 = filterBinTree notInM0 js'
- return $ replaceJudgements mi js2
+ return mi{jments=js2}
_ -> return mi
-- add the instance opens to an incomplete module "with" instances
diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs
index 78ad3e53f..1c9358816 100644
--- a/src/compiler/GF/Grammar/Analyse.hs
+++ b/src/compiler/GF/Grammar/Analyse.hs
@@ -11,7 +11,6 @@ module GF.Grammar.Analyse (
import GF.Grammar.Grammar
import GF.Infra.Ident
import GF.Infra.Option ---
-import GF.Infra.Modules
import GF.Grammar.Macros
import GF.Grammar.Lookup
diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index 7c79be361..2298ed018 100644
--- a/src/compiler/GF/Grammar/Binary.hs
+++ b/src/compiler/GF/Grammar/Binary.hs
@@ -16,7 +16,6 @@ import qualified Data.ByteString.Char8 as BS
import GF.Data.Operations
import GF.Infra.Ident
import GF.Infra.Option
-import GF.Infra.Modules
import GF.Grammar.Grammar
instance Binary Ident where
@@ -26,12 +25,12 @@ instance Binary Ident where
then return identW
else return (identC bs)
-instance Binary a => Binary (MGrammar a) where
+instance Binary SourceGrammar where
put = put . modules
get = fmap mGrammar get
-instance Binary a => Binary (ModInfo a) where
- put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,msrc mi,jments mi)
+instance Binary SourceModInfo where
+ put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi)
get = do (mtype,mstatus,flags,extend,mwith,opens,med,src,jments) <- get
return (ModInfo mtype mstatus flags extend mwith opens med src jments)
diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs
index 10f7a71fd..5a10612ec 100644
--- a/src/compiler/GF/Grammar/CF.hs
+++ b/src/compiler/GF/Grammar/CF.hs
@@ -17,7 +17,6 @@ module GF.Grammar.CF (getCF,CFItem,CFCat,CFFun,cf2gf,CFRule) where
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Infra.Ident
-import GF.Infra.Modules
import GF.Infra.Option
import GF.Infra.UseIO
@@ -84,9 +83,8 @@ type CFFun = String
cf2gf :: FilePath -> CF -> SourceGrammar
cf2gf fpath cf = mGrammar [
- (aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat}))
- (emptyModInfo{mtype = MTAbstract, msrc=fpath, jments = abs})),
- (cname, emptyModInfo{mtype = MTConcrete aname, msrc=fpath, jments = cnc})
+ (aname, ModInfo MTAbstract MSComplete (modifyFlags (\fs -> fs{optStartCat = Just cat})) [] Nothing [] [] fpath abs),
+ (cname, ModInfo (MTConcrete aname) MSComplete noOptions [] Nothing [] [] fpath cnc)
]
where
name = justModuleName fpath
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index 627355033..acf2153bc 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -14,11 +14,25 @@
-- AR 23\/1\/2000 -- 30\/5\/2001 -- 4\/5\/2003
-----------------------------------------------------------------------------
-module GF.Grammar.Grammar (SourceGrammar,
- emptySourceGrammar,mGrammar,
- SourceModInfo,
- SourceModule,
- mapSourceModule,
+module GF.Grammar.Grammar (
+ SourceGrammar, SourceModInfo(..), SourceModule, ModuleType(..),
+ emptySourceGrammar, mGrammar, modules, prependModule,
+
+ MInclude (..), OpenSpec(..),
+ extends, isInherited, inheritAll,
+ openedModule, depPathModule, allDepsModule, partOfGrammar,
+ allExtends, allExtendSpecs, allExtendsPlus, allExtensions,
+ searchPathModule,
+
+ lookupModule,
+ isModAbs, isModRes, isModCnc,
+ sameMType, isCompilableModule, isCompleteModule,
+ allAbstracts, greatestAbstract, allResources,
+ greatestResource, allConcretes, allConcreteModules,
+ abstractOfConcrete,
+
+ ModuleStatus(..),
+
Info(..),
Location(..), L(..), unLoc,
Type,
@@ -47,23 +61,258 @@ module GF.Grammar.Grammar (SourceGrammar,
import GF.Infra.Ident
import GF.Infra.Option ---
-import GF.Infra.Modules
import GF.Data.Operations
+import Data.List
+import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS
+import Text.PrettyPrint
+import System.FilePath
--- | grammar as presented to the compiler
-type SourceGrammar = MGrammar Info
-emptySourceGrammar = emptyMGrammar
+data SourceGrammar = MGrammar {
+ moduleMap :: Map.Map Ident SourceModInfo,
+ modules :: [(Ident,SourceModInfo)]
+ }
+ deriving Show
-type SourceModInfo = ModInfo Info
+data SourceModInfo = ModInfo {
+ mtype :: ModuleType,
+ mstatus :: ModuleStatus,
+ mflags :: Options,
+ mextend :: [(Ident,MInclude)],
+ mwith :: Maybe (Ident,MInclude,[(Ident,Ident)]),
+ mopens :: [OpenSpec],
+ mexdeps :: [Ident],
+ msrc :: FilePath,
+ jments :: Map.Map Ident Info
+ }
+ deriving Show
type SourceModule = (Ident, SourceModInfo)
-mapSourceModule :: (SourceModInfo -> SourceModInfo) -> (SourceModule -> SourceModule)
-mapSourceModule f (i,mi) = (i, f mi)
+-- | encoding the type of the module
+data ModuleType =
+ MTAbstract
+ | MTResource
+ | MTConcrete Ident
+ | MTInterface
+ | MTInstance (Ident,MInclude)
+ deriving (Eq,Show)
+
+data MInclude = MIAll | MIOnly [Ident] | MIExcept [Ident]
+ deriving (Eq,Show)
+
+extends :: SourceModInfo -> [Ident]
+extends = map fst . mextend
+
+isInherited :: MInclude -> Ident -> Bool
+isInherited c i = case c of
+ MIAll -> True
+ MIOnly is -> elem i is
+ MIExcept is -> notElem i is
+
+inheritAll :: Ident -> (Ident,MInclude)
+inheritAll i = (i,MIAll)
+
+addOpenQualif :: Ident -> Ident -> SourceModInfo -> SourceModInfo
+addOpenQualif i j (ModInfo mt ms fs me mw ops med src js) = ModInfo mt ms fs me mw (OQualif i j : ops) med src js
+
+data OpenSpec =
+ OSimple Ident
+ | OQualif Ident Ident
+ deriving (Eq,Show)
+
+data ModuleStatus =
+ MSComplete
+ | MSIncomplete
+ deriving (Eq,Ord,Show)
+
+openedModule :: OpenSpec -> Ident
+openedModule o = case o of
+ OSimple m -> m
+ OQualif _ m -> m
+
+-- | initial dependency list
+depPathModule :: SourceModInfo -> [OpenSpec]
+depPathModule m = fors m ++ exts m ++ mopens m
+ where
+ fors m =
+ case mtype m of
+ MTConcrete i -> [OSimple i]
+ MTInstance (i,_) -> [OSimple i]
+ _ -> []
+ exts m = map OSimple (extends m)
+
+-- | all dependencies
+allDepsModule :: SourceGrammar -> SourceModInfo -> [OpenSpec]
+allDepsModule gr m = iterFix add os0 where
+ os0 = depPathModule m
+ add os = [m | o <- os, Just n <- [lookup (openedModule o) mods],
+ m <- depPathModule n]
+ mods = modules gr
+
+-- | select just those modules that a given one depends on, including itself
+partOfGrammar :: SourceGrammar -> (Ident,SourceModInfo) -> SourceGrammar
+partOfGrammar gr (i,m) = mGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
+ where
+ mods = modules gr
+ modsFor = (i:) $ map openedModule $ allDepsModule gr m
+
+-- | all modules that a module extends, directly or indirectly, without restricts
+allExtends :: SourceGrammar -> Ident -> [Ident]
+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 :: SourceGrammar -> Ident -> [(Ident,MInclude)]
+allExtendSpecs gr i =
+ case lookupModule gr i of
+ Ok m -> case mextend m of
+ [] -> [(i,MIAll)]
+ is -> (i,MIAll) : concatMap (allExtendSpecs gr . fst) is
+ _ -> []
+
+-- | this plus that an instance extends its interface
+allExtendsPlus :: SourceGrammar -> Ident -> [Ident]
+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 :: SourceGrammar -> Ident -> [Ident]
+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) || isInstanceOf i m]
+ mods = modules gr
+ isInstanceOf i m = case mtype m of
+ MTInstance (j,_) -> j == i
+ _ -> False
+
+-- | initial search path: the nonqualified dependencies
+searchPathModule :: SourceModInfo -> [Ident]
+searchPathModule m = [i | OSimple i <- depPathModule m]
+
+prependModule (MGrammar mm ms) im@(i,m) = MGrammar (Map.insert i m mm) (im:ms)
+
+emptySourceGrammar :: SourceGrammar
+emptySourceGrammar = mGrammar []
+
+mGrammar ms = MGrammar (Map.fromList ms) ms
+
+
+-- | we store the module type with the identifier
+
+abstractOfConcrete :: SourceGrammar -> Ident -> Err Ident
+abstractOfConcrete gr c = do
+ n <- lookupModule gr c
+ case mtype n of
+ MTConcrete a -> return a
+ _ -> Bad $ render (text "expected concrete" <+> ppIdent c)
+
+lookupModule :: SourceGrammar -> Ident -> Err SourceModInfo
+lookupModule gr m = case Map.lookup m (moduleMap gr) of
+ Just i -> return i
+ Nothing -> Bad $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr)))
+
+isModAbs :: SourceModInfo -> Bool
+isModAbs m =
+ case mtype m of
+ MTAbstract -> True
+ _ -> False
+
+isModRes :: SourceModInfo -> Bool
+isModRes m =
+ case mtype m of
+ MTResource -> True
+ MTInterface -> True ---
+ MTInstance _ -> True
+ _ -> False
+
+isModCnc :: SourceModInfo -> Bool
+isModCnc m =
+ case mtype m of
+ MTConcrete _ -> True
+ _ -> False
+
+sameMType :: ModuleType -> ModuleType -> Bool
+sameMType m n =
+ case (n,m) of
+ (MTConcrete _, MTConcrete _) -> True
+
+ (MTInstance _, MTInstance _) -> True
+ (MTInstance _, MTResource) -> True
+ (MTInstance _, MTConcrete _) -> True
+
+ (MTInterface, MTInstance _) -> True
+ (MTInterface, MTResource) -> True -- for reuse
+ (MTInterface, MTAbstract) -> True -- for reuse
+ (MTInterface, MTConcrete _) -> True -- for reuse
+
+ (MTResource, MTInstance _) -> True
+ (MTResource, MTConcrete _) -> True -- for reuse
+
+ _ -> m == n
+
+-- | don't generate code for interfaces and for incomplete modules
+isCompilableModule :: SourceModInfo -> Bool
+isCompilableModule m =
+ case mtype m of
+ MTInterface -> False
+ _ -> mstatus m == MSComplete
+
+-- | interface and "incomplete M" are not complete
+isCompleteModule :: SourceModInfo -> Bool
+isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
+
+
+-- | all abstract modules sorted from least to most dependent
+allAbstracts :: SourceGrammar -> [Ident]
+allAbstracts gr =
+ case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
+ Left is -> is
+ Right cycles -> error $ render (text "Cyclic abstract modules:" <+> vcat (map (hsep . map ppIdent) cycles))
+
+-- | the last abstract in dependency order (head of list)
+greatestAbstract :: SourceGrammar -> Maybe Ident
+greatestAbstract gr =
+ case allAbstracts gr of
+ [] -> Nothing
+ as -> return $ last as
+
+-- | all resource modules
+allResources :: SourceGrammar -> [Ident]
+allResources gr = [i | (i,m) <- modules gr, isModRes m || isModCnc m]
+
+-- | the greatest resource in dependency order
+greatestResource :: SourceGrammar -> Maybe Ident
+greatestResource gr =
+ case allResources gr of
+ [] -> Nothing
+ a -> return $ head a ---- why not last as in Abstract? works though AR 24/5/2008
+
+-- | all concretes for a given abstract
+allConcretes :: SourceGrammar -> Ident -> [Ident]
+allConcretes gr a =
+ [i | (i, m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
+
+-- | all concrete modules for any abstract
+allConcreteModules :: SourceGrammar -> [Ident]
+allConcreteModules gr =
+ [i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
+
+
-- | the constructors are judgements in
--
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 651fde4d0..7e743dd16 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -17,7 +17,6 @@
module GF.Grammar.Lookup (
lookupIdent,
--- lookupIdentInfo,
lookupOrigInfo,
allOrigInfos,
lookupResDef,
@@ -34,7 +33,6 @@ module GF.Grammar.Lookup (
import GF.Data.Operations
import GF.Infra.Ident
-import GF.Infra.Modules
import GF.Grammar.Macros
import GF.Grammar.Grammar
import GF.Grammar.Printer
@@ -57,10 +55,10 @@ lookupIdent c t =
Ok v -> return v
Bad _ -> Bad ("unknown identifier" +++ showIdent c)
-lookupIdentInfo :: ModInfo a -> Ident -> Err a
+lookupIdentInfo :: SourceModInfo -> Ident -> Err Info
lookupIdentInfo mo i = lookupIdent i (jments mo)
-lookupQIdentInfo :: MGrammar info -> QIdent -> Err info
+lookupQIdentInfo :: SourceGrammar -> QIdent -> Err Info
lookupQIdentInfo gr (m,c) = flip lookupIdentInfo c =<< lookupModule gr m
lookupResDef :: SourceGrammar -> QIdent -> Err Term
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index 38b22aaa2..8af343fc6 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -21,7 +21,6 @@ module GF.Grammar.Macros where
import GF.Data.Operations
import GF.Data.Str
import GF.Infra.Ident
-import GF.Infra.Modules
import GF.Grammar.Grammar
import GF.Grammar.Values
import GF.Grammar.Predef
@@ -584,4 +583,4 @@ pSeq p1 p2 =
(PSeq p11 (PString s1),PSeq (PString s2) p22) ->
PSeq p11 (PSeq (PString (s1++s2)) p22)
_ -> PSeq p1 p2
--} \ No newline at end of file
+-}
diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y
index 26b7e123b..6c83d72a0 100644
--- a/src/compiler/GF/Grammar/Parser.y
+++ b/src/compiler/GF/Grammar/Parser.y
@@ -9,7 +9,6 @@ module GF.Grammar.Parser
) where
import GF.Infra.Ident
-import GF.Infra.Modules
import GF.Infra.Option
import GF.Data.Operations
import GF.Grammar.Predef
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index ce8562db7..f65d26f89 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -22,7 +22,6 @@ module GF.Grammar.Printer
) where
import GF.Infra.Ident
-import GF.Infra.Modules
import GF.Infra.Option
import GF.Grammar.Values
import GF.Grammar.Grammar
diff --git a/src/compiler/GF/Infra/Dependencies.hs b/src/compiler/GF/Infra/Dependencies.hs
index 393d0e8c8..d90cbbae6 100644
--- a/src/compiler/GF/Infra/Dependencies.hs
+++ b/src/compiler/GF/Infra/Dependencies.hs
@@ -3,7 +3,6 @@ module GF.Infra.Dependencies (
) where
import GF.Grammar.Grammar
-import GF.Infra.Modules
import GF.Infra.Ident
import Data.List (nub,isPrefixOf)
@@ -60,8 +59,8 @@ grammar2moddeps monly gr = [(i,depMod i m) | (i,m) <- modules gr, yes i]
MTConcrete i -> [i | yes i]
MTInstance (i,_) -> [i | yes i]
_ -> [],
- extendeds = nub $ filter yes $ map fst (extend m),
- openeds = nub $ filter yes $ map openedModule (opens m),
+ extendeds = nub $ filter yes $ map fst (mextend m),
+ openeds = nub $ filter yes $ map openedModule (mopens m),
extrads = nub $ filter yes $ mexdeps m
}
yes i = case monly of
diff --git a/src/compiler/GF/Infra/Modules.hs b/src/compiler/GF/Infra/Modules.hs
deleted file mode 100644
index 67e010ece..000000000
--- a/src/compiler/GF/Infra/Modules.hs
+++ /dev/null
@@ -1,340 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Modules
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/09 15:14:30 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.26 $
---
--- Datastructures and functions for modules, common to GF and GFC.
---
--- AR 29\/4\/2003
---
--- The same structure will be used in both source code and canonical.
--- The parameters tell what kind of data is involved.
------------------------------------------------------------------------------
-
-module GF.Infra.Modules (
- MGrammar, ModInfo(..), ModuleType(..),
- MInclude (..),
- mGrammar,modules,prependModule,
- extends, isInherited,inheritAll,
- updateModule, replaceJudgements, addFlag,
- addOpenQualif, flagsModule, allFlags,
- OpenSpec(..),
- ModuleStatus(..),
- openedModule, depPathModule, allDepsModule, partOfGrammar,
- allExtends, allExtendSpecs, allExtendsPlus, allExtensions,
- searchPathModule,
- -- addModule, mapModules, updateMGrammar,
- emptyMGrammar, emptyModInfo,
- abstractOfConcrete, abstractModOfConcrete,
- lookupModule, lookupModuleType, lookupInfo,
- isModAbs, isModRes, isModCnc,
- sameMType, isCompilableModule, isCompleteModule,
- allAbstracts, greatestAbstract, allResources,
- greatestResource, allConcretes, allConcreteModules
- ) where
-
-import GF.Infra.Ident
-import GF.Infra.Option
-import GF.Data.Operations
-
-import Data.List
-import qualified Data.Map as Map
-import Text.PrettyPrint
-import System.FilePath
-
-
--- Invariant: modules are stored in dependency order
-
-data MGrammar a = MGrammar { moduleMap :: Map.Map Ident (ModInfo a),
- modules :: [(Ident,ModInfo a)] }
- deriving Show
-mGrammar ms = MGrammar (Map.fromList ms) ms
-
-data ModInfo a = ModInfo {
- mtype :: ModuleType,
- mstatus :: ModuleStatus,
- flags :: Options,
- extend :: [(Ident,MInclude)],
- mwith :: Maybe (Ident,MInclude,[(Ident,Ident)]),
- opens :: [OpenSpec],
- mexdeps :: [Ident],
- msrc :: FilePath,
- jments :: Map.Map Ident a
- }
- deriving Show
-
--- | encoding the type of the module
-data ModuleType =
- MTAbstract
- | MTResource
- | MTConcrete Ident
- -- ^ up to this, also used in GFO. Below, source only.
- | MTInterface
- | MTInstance (Ident,MInclude)
- deriving (Eq,Show)
-
-data MInclude = MIAll | MIOnly [Ident] | MIExcept [Ident]
- deriving (Eq,Show)
-
-extends :: ModInfo a -> [Ident]
-extends = map fst . extend
-
-isInherited :: MInclude -> Ident -> Bool
-isInherited c i = case c of
- MIAll -> True
- MIOnly is -> elem i is
- MIExcept is -> notElem i is
-
-inheritAll :: Ident -> (Ident,MInclude)
-inheritAll i = (i,MIAll)
-
--- destructive update
-{-
--- | dep order preserved since old cannot depend on new
-updateMGrammar :: MGrammar a -> MGrammar a -> MGrammar a
-updateMGrammar (MGrammar omap os) (MGrammar nmap ns) =
- MGrammar (Map.union nmap omap) -- Map.union is left-biased
- ([im | im@(i,m) <- os, i `notElem` nis] ++ ns)
- where
- nis = map fst ns
--}
-updateModule :: ModInfo t -> Ident -> t -> ModInfo t
-updateModule (ModInfo mt ms fs me mw ops med src js) i t = ModInfo mt ms fs me mw ops med src (updateTree (i,t) js)
-
-replaceJudgements :: ModInfo t -> Map.Map Ident t -> ModInfo t
-replaceJudgements (ModInfo mt ms fs me mw ops med src _) js = ModInfo mt ms fs me mw ops med src js
-
-addOpenQualif :: Ident -> Ident -> ModInfo t -> ModInfo t
-addOpenQualif i j (ModInfo mt ms fs me mw ops med src js) = ModInfo mt ms fs me mw (OQualif i j : ops) med src js
-
-addFlag :: Options -> ModInfo t -> ModInfo t
-addFlag f mo = mo {flags = flags mo `addOptions` f}
-
-flagsModule :: (Ident,ModInfo a) -> Options
-flagsModule (_,mi) = flags mi
-
-allFlags :: MGrammar a -> Options
-allFlags gr = concatOptions [flags m | (_,m) <- modules gr]
-{-
-mapModules :: (ModInfo a -> ModInfo a) -> MGrammar a -> MGrammar a
-mapModules f = mGrammar . map (onSnd f) . modules
--}
-data OpenSpec =
- OSimple Ident
- | OQualif Ident Ident
- deriving (Eq,Show)
-
-data ModuleStatus =
- MSComplete
- | MSIncomplete
- deriving (Eq,Ord,Show)
-
-openedModule :: OpenSpec -> Ident
-openedModule o = case o of
- OSimple m -> m
- OQualif _ m -> m
-
--- | initial dependency list
-depPathModule :: ModInfo a -> [OpenSpec]
-depPathModule m = fors m ++ exts m ++ opens m
- where
- fors m =
- case mtype m of
- MTConcrete i -> [OSimple i]
- MTInstance (i,_) -> [OSimple i]
- _ -> []
- exts m = map OSimple (extends m)
-
--- | all dependencies
-allDepsModule :: MGrammar a -> ModInfo a -> [OpenSpec]
-allDepsModule gr m = iterFix add os0 where
- os0 = depPathModule m
- add os = [m | o <- os, Just n <- [lookup (openedModule o) mods],
- m <- depPathModule n]
- mods = modules gr
-
--- | select just those modules that a given one depends on, including itself
-partOfGrammar :: MGrammar a -> (Ident,ModInfo a) -> MGrammar a
-partOfGrammar gr (i,m) = mGrammar [mo | mo@(j,_) <- mods, elem j modsFor]
- where
- mods = modules gr
- modsFor = (i:) $ map openedModule $ allDepsModule gr m
-
--- | all modules that a module extends, directly or indirectly, without restricts
-allExtends :: MGrammar a -> Ident -> [Ident]
-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 :: MGrammar a -> Ident -> [(Ident,MInclude)]
-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 :: MGrammar a -> Ident -> [Ident]
-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 :: MGrammar a -> Ident -> [Ident]
-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) || isInstanceOf i m]
- mods = modules gr
- isInstanceOf i m = case mtype m of
- MTInstance (j,_) -> j == i
- _ -> False
-
--- | initial search path: the nonqualified dependencies
-searchPathModule :: ModInfo a -> [Ident]
-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 :: MGrammar a -> Ident -> ModInfo a -> MGrammar a
---addModule gr name mi = MGrammar $ (modules gr ++ [(name,mi)])
-addModule gr name mi = MGrammar $ Map.insert name mi (moduleMap gr)
--}
-
-prependModule (MGrammar mm ms) im@(i,m) = MGrammar (Map.insert i m mm) (im:ms)
-
-emptyMGrammar :: MGrammar a
-emptyMGrammar = mGrammar []
-
-emptyModInfo :: ModInfo a
-emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "" emptyBinTree
-
--- | we store the module type with the identifier
-
-abstractOfConcrete :: MGrammar a -> Ident -> Err Ident
-abstractOfConcrete gr c = do
- n <- lookupModule gr c
- case mtype n of
- MTConcrete a -> return a
- _ -> Bad $ render (text "expected concrete" <+> ppIdent c)
-
-abstractModOfConcrete :: MGrammar a -> Ident -> Err (ModInfo a)
-abstractModOfConcrete gr c = lookupModule gr =<< abstractOfConcrete gr c
-
--- the canonical file name
-
---- canonFileName s = prt s ++ ".gfc"
-
-lookupModule :: MGrammar a -> Ident -> Err (ModInfo a)
---lookupModule gr m = case lookup m (modules gr) of
-lookupModule gr m = case Map.lookup m (moduleMap gr) of
- Just i -> return i
- Nothing -> Bad $ render (text "unknown module" <+> ppIdent m <+> text "among" <+> hsep (map (ppIdent . fst) (modules gr)))
-
-lookupModuleType :: MGrammar a -> Ident -> Err ModuleType
-lookupModuleType gr m = mtype `fmap` lookupModule gr m
-
-lookupInfo :: ModInfo a -> Ident -> Err a
-lookupInfo mo i = lookupTree showIdent i (jments mo)
-
-isModAbs :: ModInfo a -> Bool
-isModAbs m =
- case mtype m of
- MTAbstract -> True
- _ -> False
-
-isModRes :: ModInfo a -> Bool
-isModRes m =
- case mtype m of
- MTResource -> True
- MTInterface -> True ---
- MTInstance _ -> True
- _ -> False
-
-isModCnc :: ModInfo a -> Bool
-isModCnc m =
- case mtype m of
- MTConcrete _ -> True
- _ -> False
-
-sameMType :: ModuleType -> ModuleType -> Bool
-sameMType m n =
- case (n,m) of
- (MTConcrete _, MTConcrete _) -> True
-
- (MTInstance _, MTInstance _) -> True
- (MTInstance _, MTResource) -> True
- (MTInstance _, MTConcrete _) -> True
-
- (MTInterface, MTInstance _) -> True
- (MTInterface, MTResource) -> True -- for reuse
- (MTInterface, MTAbstract) -> True -- for reuse
- (MTInterface, MTConcrete _) -> True -- for reuse
-
- (MTResource, MTInstance _) -> True
- (MTResource, MTConcrete _) -> True -- for reuse
-
- _ -> m == n
-
--- | don't generate code for interfaces and for incomplete modules
-isCompilableModule :: ModInfo a -> Bool
-isCompilableModule m =
- case mtype m of
- MTInterface -> False
- _ -> mstatus m == MSComplete
-
--- | interface and "incomplete M" are not complete
-isCompleteModule :: ModInfo a -> Bool
-isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface
-
-
--- | all abstract modules sorted from least to most dependent
-allAbstracts :: MGrammar a -> [Ident]
-allAbstracts gr =
- case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of
- Left is -> is
- Right cycles -> error $ render (text "Cyclic abstract modules:" <+> vcat (map (hsep . map ppIdent) cycles))
-
--- | the last abstract in dependency order (head of list)
-greatestAbstract :: MGrammar a -> Maybe Ident
-greatestAbstract gr =
- case allAbstracts gr of
- [] -> Nothing
- as -> return $ last as
-
--- | all resource modules
-allResources :: MGrammar a -> [Ident]
-allResources gr = [i | (i,m) <- modules gr, isModRes m || isModCnc m]
-
--- | the greatest resource in dependency order
-greatestResource :: MGrammar a -> Maybe Ident
-greatestResource gr =
- case allResources gr of
- [] -> Nothing
- a -> return $ head a ---- why not last as in Abstract? works though AR 24/5/2008
-
--- | all concretes for a given abstract
-allConcretes :: MGrammar a -> Ident -> [Ident]
-allConcretes gr a =
- [i | (i, m) <- modules gr, mtype m == MTConcrete a, isCompleteModule m]
-
--- | all concrete modules for any abstract
-allConcreteModules :: MGrammar a -> [Ident]
-allConcreteModules gr =
- [i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
diff --git a/src/compiler/GF/Speech/VoiceXML.hs b/src/compiler/GF/Speech/VoiceXML.hs
index 308806bea..57168c78c 100644
--- a/src/compiler/GF/Speech/VoiceXML.hs
+++ b/src/compiler/GF/Speech/VoiceXML.hs
@@ -11,7 +11,6 @@ import GF.Data.Str (sstrV)
import GF.Data.Utilities
import GF.Data.XML
import GF.Infra.Ident
-import GF.Infra.Modules
import PGF
import PGF.Data
import PGF.Macros
diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs
index 7017c920e..5b807eb7a 100644
--- a/src/compiler/GFI.hs
+++ b/src/compiler/GFI.hs
@@ -21,7 +21,6 @@ import GF.Infra.Dependencies
import GF.Infra.CheckM
import GF.Infra.UseIO
import GF.Infra.Option
-import GF.Infra.Modules (greatestResource, modules, emptyModInfo, mGrammar)
import GF.Infra.Ident (showIdent)
import GF.Infra.BuildInfo (buildInfo)
import qualified System.Console.Haskeline as Haskeline
@@ -402,13 +401,12 @@ prompt env
data GFEnv = GFEnv {
sourcegrammar :: SourceGrammar, -- gfo grammar -retain
commandenv :: CommandEnv,
- history :: [String]--,
---cputime :: Integer
+ history :: [String]
}
emptyGFEnv :: GFEnv
emptyGFEnv =
- GFEnv (mGrammar [(identW,emptyModInfo)]) (mkCommandEnv emptyPGF) [] {-0-}
+ GFEnv emptySourceGrammar (mkCommandEnv emptyPGF) [] {-0-}
wordCompletion gfenv (left,right) = do
case wc_type (reverse left) of
diff --git a/src/compiler/GFTags.hs b/src/compiler/GFTags.hs
index 7e56f9a4f..fd75710e3 100644
--- a/src/compiler/GFTags.hs
+++ b/src/compiler/GFTags.hs
@@ -1,7 +1,6 @@
module GFTags where
import GF.Infra.Option
-import GF.Infra.Modules
import GF.Infra.UseIO
import GF.Grammar
import GF.Compile