GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-03 00:02:50 -06:00
Code Issues Packages Projects Releases Wiki 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

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