diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index f5cbde7b7..9693150ff 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -203,25 +203,24 @@ compileSourceModule opts env@(k,gr,_) mb_gfFile mo@(i,mi) = do Nothing -> return () extendCompileEnvInt env k Nothing mo1b _ -> do - let mos = modules gr - (mo2,warnings) <- putpp " renaming " $ ioeErr $ runCheck (renameModule mos mo1b) + (mo2,warnings) <- putpp " renaming " $ ioeErr $ runCheck (renameModule gr mo1b) warnOut opts warnings intermOut opts DumpRename (ppModule Internal mo2) - (mo3,warnings) <- putpp " type checking" $ ioeErr $ runCheck (checkModule opts mos mo2) + (mo3,warnings) <- putpp " type checking" $ ioeErr $ runCheck (checkModule opts gr mo2) warnOut opts warnings intermOut opts DumpTypeCheck (ppModule Internal mo3) if not (flag optTagsOnly opts) - then do (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 + then do (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,gr) mo3 intermOut opts DumpRefresh (ppModule Internal mo3r) - mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r + mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts gr mo3r intermOut opts DumpOptimize (ppModule Internal mo4) mo5 <- if isModCnc (snd mo4) && flag optPMCFG opts - then putpp " generating PMCFG " $ ioeIO $ generatePMCFG opts mos mo4 + then putpp " generating PMCFG " $ ioeIO $ generatePMCFG opts gr mo4 else return mo4 intermOut opts DumpCanon (ppModule Internal mo5) diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 5988a20c8..0c72c67fe 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -45,11 +45,11 @@ import Control.Monad import Text.PrettyPrint -- | checking is performed in the dependency order of modules -checkModule :: Options -> [SourceModule] -> SourceModule -> Check SourceModule -checkModule opts mos mo@(m,mi) = do - checkRestrictedInheritance mos mo +checkModule :: Options -> SourceGrammar -> SourceModule -> Check SourceModule +checkModule opts sgr mo@(m,mi) = do + checkRestrictedInheritance sgr mo mo <- case mtype mi of - MTConcrete a -> do let gr = mGrammar (mo:mos) + MTConcrete a -> do let gr = prependModule sgr mo abs <- checkErr $ lookupModule gr a checkCompleteGrammar gr (a,abs) mo _ -> return mo @@ -57,18 +57,19 @@ checkModule opts mos mo@(m,mi) = do foldM updateCheckInfos mo infoss where updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check - where check (i,info) = fmap ((,) i) (checkInfo opts mos mo i info) + where check (i,info) = fmap ((,) i) (checkInfo opts sgr mo i info) update mo@(m,mi) (i,info) = (m,mi{jments=updateTree (i,info) (jments mi)}) -- 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) = checkIn (ppLocation (msrc mo) NoLoc <> colon) $ do +checkRestrictedInheritance :: SourceGrammar -> SourceModule -> Check () +checkRestrictedInheritance sgr (name,mo) = checkIn (ppLocation (msrc mo) NoLoc <> colon) $ do 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 where + mos = modules sgr checkRem ((i,m),mi) = do let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m))) let incld c = Set.member c (Set.fromList incl) @@ -153,8 +154,8 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc) NoLoc -- | General Principle: only Just-values are checked. -- A May-value has always been checked in its origin module. -checkInfo :: Options -> [SourceModule] -> SourceModule -> Ident -> Info -> Check Info -checkInfo opts ms (m,mo) c info = do +checkInfo :: Options -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info +checkInfo opts sgr (m,mo) c info = do checkIn (ppLocation (msrc mo) NoLoc <> colon) $ checkReservedId c case info of @@ -253,7 +254,7 @@ checkInfo opts ms (m,mo) c info = do _ -> return info where - gr = mGrammar ((m,mo) : ms) + gr = prependModule sgr (m,mo) chIn loc cat = checkIn (ppLocation (msrc mo) loc <> colon $$ nest 2 (text "Happened in" <+> text cat <+> ppIdent c)) diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index bb4c5b549..13ac8d26f 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -43,13 +43,13 @@ import Control.Exception ---------------------------------------------------------------------- -- main conversion function -generatePMCFG :: Options -> [SourceModule] -> SourceModule -> IO SourceModule -generatePMCFG opts mos cmo@(cm,cmi) = do +generatePMCFG :: Options -> SourceGrammar -> SourceModule -> IO SourceModule +generatePMCFG opts sgr cmo@(cm,cmi) = do (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr am cm) Map.empty (jments cmi) when (verbAtLeast opts Verbose) $ hPutStrLn stderr "" return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js}) where - gr = mGrammar (cmo:mos) + gr = prependModule sgr cmo MTConcrete am = mtype cmi mapAccumWithKeyM :: (Monad m, Ord k) => (a -> k -> b -> m (a,c)) -> a diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs index 33632f5bf..635a1732c 100644 --- a/src/compiler/GF/Compile/Optimize.hs +++ b/src/compiler/GF/Compile/Optimize.hs @@ -40,8 +40,8 @@ import qualified Data.ByteString.Char8 as BS -- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. -optimizeModule :: Options -> [SourceModule] -> SourceModule -> Err SourceModule -optimizeModule opts ms m@(name,mi) +optimizeModule :: Options -> SourceGrammar -> SourceModule -> Err SourceModule +optimizeModule opts sgr m@(name,mi) | mstatus mi == MSComplete = do ids <- topoSortJments m mi <- foldM updateEvalInfo mi ids @@ -51,11 +51,11 @@ optimizeModule opts ms m@(name,mi) oopts = opts `addOptions` mflags mi updateEvalInfo mi (i,info) = do - info <- evalInfo oopts ms (name,mi) i info + info <- evalInfo oopts sgr (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 +evalInfo :: Options -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info +evalInfo opts sgr m c info = do (if verbAtLeast opts Verbose then trace (" " ++ showIdent c) else id) return () @@ -95,7 +95,7 @@ evalInfo opts ms m c info = do _ -> return info where - gr = mGrammar (m : ms) + gr = prependModule sgr m optim = flag optOptimizations opts param = OptParametrize `Set.member` optim eIn cat = errIn (render (text "Error optimizing" <+> cat <+> ppIdent c <+> colon)) diff --git a/src/compiler/GF/Compile/Refresh.hs b/src/compiler/GF/Compile/Refresh.hs index b66e88aa3..edff8a479 100644 --- a/src/compiler/GF/Compile/Refresh.hs +++ b/src/compiler/GF/Compile/Refresh.hs @@ -106,15 +106,15 @@ refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) whe -- for concrete and resource in grammar, before optimizing -refreshGrammar :: SourceGrammar -> Err SourceGrammar -refreshGrammar = liftM (mGrammar . snd) . foldM refreshModule (0,[]) . modules +--refreshGrammar :: SourceGrammar -> Err SourceGrammar +--refreshGrammar = liftM (mGrammar . snd) . foldM refreshModule (0,[]) . modules -refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule]) -refreshModule (k,ms) mi@(i,mo) +refreshModule :: (Int,SourceGrammar) -> SourceModule -> Err (Int,[SourceModule]) +refreshModule (k,sgr) mi@(i,mo) | isModCnc mo || isModRes mo = do (k',js') <- foldM refreshRes (k,[]) $ tree2list $ jments mo - return (k', (i,mo{jments=buildTree js'}) : ms) - | otherwise = return (k, mi:ms) + return (k', (i,mo{jments=buildTree js'}) : modules sgr) + | otherwise = return (k, mi:modules sgr) where refreshRes (k,cs) ci@(c,info) = case info of ResOper ptyp (Just (L loc trm)) -> do ---- refresh ptyp diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index f2dbf7d69..9e959c353 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -49,9 +49,9 @@ renameSourceTerm g m t = do status <- buildStatus g (m,mi) renameTerm status [] t -renameModule :: [SourceModule] -> SourceModule -> Check SourceModule -renameModule ms mo@(m,mi) = do - status <- buildStatus (mGrammar ms) mo +renameModule :: SourceGrammar -> SourceModule -> Check SourceModule +renameModule gr mo@(m,mi) = do + status <- buildStatus gr mo js <- checkMapRecover (renameInfo status mo) (jments mi) return (m, mi{jments = js})