msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Consistenly use SourceGrammar instead of [SourceModule] when calling compiler passes

Browse Source
This commit is contained in:
hallgren
2012-10-19 19:56:00 +00:00
parent 921b37834c
commit 1195db1da3
6 changed files with 34 additions and 34 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
src/compiler/GF/Compile.hs
View File

@@ -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)

21
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -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))

6
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -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

12
src/compiler/GF/Compile/Optimize.hs
View File

@@ -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))

12
src/compiler/GF/Compile/Refresh.hs
View File

@@ -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

6
src/compiler/GF/Compile/Rename.hs
View File

@@ -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})