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

merge GF.Infra.Modules and GF.Grammar.Grammar. This is a preparation for the separate PGF building

Browse Source
This commit is contained in:
kr.angelov
2011-11-02 13:57:11 +00:00
parent 5fe49ed9f7
commit 734c66710e
30 changed files with 322 additions and 451 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
gf.cabal
View File

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

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

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

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

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

3
src/compiler/GF/Compile/Coding.hs
View File

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

1
src/compiler/GF/Compile/Compute/AppPredefined.hs
View File

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

1
src/compiler/GF/Compile/Compute/ConcreteLazy.hs
View File

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

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

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

15
src/compiler/GF/Compile/GetGrammar.hs
View File

@@ -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 ()
removeTemp _ = return ()

23
src/compiler/GF/Compile/GrammarToPGF.hs
View File

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

10
src/compiler/GF/Compile/ModDeps.hs
View File

@@ -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]
_ -> [] ----

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

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

5
src/compiler/GF/Compile/ReadFiles.hs
View File

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

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

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

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

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

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

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

1
src/compiler/GF/Compile/TypeCheck/Concrete.hs
View File

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

9
src/compiler/GF/Compile/Update.hs
View File

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

1
src/compiler/GF/Grammar/Analyse.hs
View File

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

7
src/compiler/GF/Grammar/Binary.hs
View File

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

6
src/compiler/GF/Grammar/CF.hs
View File

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

273
src/compiler/GF/Grammar/Grammar.hs
View File

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

6
src/compiler/GF/Grammar/Lookup.hs
View File

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

3
src/compiler/GF/Grammar/Macros.hs
View File

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

1
src/compiler/GF/Grammar/Parser.y
View File

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

1
src/compiler/GF/Grammar/Printer.hs
View File

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

5
src/compiler/GF/Infra/Dependencies.hs
View File

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

340
src/compiler/GF/Infra/Modules.hs
View File

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

1
src/compiler/GF/Speech/VoiceXML.hs
View File

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

6
src/compiler/GFI.hs
View File

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

1
src/compiler/GFTags.hs
View File

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