diff --git a/gf.cabal b/gf.cabal index cb704ad04..3028ab50d 100644 --- a/gf.cabal +++ b/gf.cabal @@ -132,7 +132,6 @@ executable gf GF.JavaScript.AbsJS GF.JavaScript.PrintJS GF.Infra.Ident - GF.Infra.Modules GF.Infra.GetOpt GF.Infra.Option GF.Infra.UseIO 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