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

refactor the GF.Grammar.Grammar syntax. The obsolete constructions are removed

Browse Source
This commit is contained in:
krasimir
2009-01-19 13:23:03 +00:00
parent fa7ab84471
commit d95ca4a103
25 changed files with 325 additions and 542 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/GF/Source/CF.hs
View File

@@ -81,8 +81,8 @@ type CFFun = String
cf2gf :: String -> CF -> SourceGrammar
cf2gf name cf = MGrammar [
(aname, ModMod (emptyModule {mtype = MTAbstract, jments = abs})),
(cname, ModMod (emptyModule {mtype = MTConcrete aname, jments = cnc}))
(aname, emptyModInfo{mtype = MTAbstract, jments = abs}),
(cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc})
]
where
(abs,cnc) = cf2grammar cf

19
src/GF/Source/GrammarToSource.hs
View File

@@ -35,13 +35,13 @@ trGrammar :: SourceGrammar -> P.Grammar
trGrammar (MGrammar ms) = P.Gr (map trModule ms) -- no includes
trModule :: (Ident,SourceModInfo) -> P.ModDef
trModule (i,mo) = case mo of
ModMod m -> P.MModule compl typ body where
trModule (i,m) = P.MModule compl typ body
where
compl = case mstatus m of
MSIncomplete -> P.CMIncompl
_ -> P.CMCompl
i' = tri i
typ = case typeOfModule mo of
typ = case mtype m of
MTResource -> P.MTResource i'
MTAbstract -> P.MTAbstract i'
MTConcrete a -> P.MTConcrete i' (tri a)
@@ -66,15 +66,8 @@ forName (MTConcrete a) = tri a
trOpen :: OpenSpec Ident -> P.Open
trOpen o = case o of
OSimple OQNormal i -> P.OName (tri i)
OSimple q i -> P.OQualQO (trQualOpen q) (tri i)
OQualif q i j -> P.OQual (trQualOpen q) (tri i) (tri j)
trQualOpen q = case q of
OQNormal -> P.QOCompl
OQIncomplete -> P.QOIncompl
OQInterface -> P.QOInterface
OSimple i -> P.OName (tri i)
OQualif i j -> P.OQual P.QOCompl (tri i) (tri j)
mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds
mkTopDefs ds = ds
@@ -87,8 +80,6 @@ trAnyDef (i,info) = let i' = tri i in case info of
Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]]
_ -> []
AbsFun (May b) _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]]
---- don't destroy definitions!
AbsTrans f -> [P.DefTrans [P.DDef [mkName i'] (trt f)]]
ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]]
ResParam pp -> [P.DefPar [case pp of

53
src/GF/Source/SourceToGrammar.hs
View File

@@ -70,15 +70,9 @@ transGrammar x = case x of
moddefs' <- mapM transModDef moddefs
GD.mkSourceGrammar moddefs'
transModDef :: ModDef -> Err (Ident, G.SourceModInfo)
transModDef :: ModDef -> Err G.SourceModule
transModDef x = case x of
MMain id0 id concspecs -> do
id0' <- transIdent id0
id' <- transIdent id
concspecs' <- mapM transConcSpec concspecs
return $ (id0', GM.ModMainGrammar (GM.MainGrammar id' concspecs'))
MModule compl mtyp body -> do
let mstat' = transComplMod compl
@@ -117,14 +111,7 @@ transModDef x = case x of
defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatOptions [o | Right o <- defs0]
let poss1 = buildPosTree id' poss0
return (id',
GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1))
MReuse _ -> do
return (id', GM.ModMod (GM.Module mtyp' mstat' noOptions [] [] emptyBinTree poss))
MUnion imps -> do
imps' <- mapM transIncluded imps
return (id',
GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' noOptions [] [] emptyBinTree poss))
return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' defs' poss1)
MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
@@ -139,21 +126,11 @@ transModDef x = case x of
defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatOptions [o | Right o <- defs0]
let poss1 = buildPosTree id' poss0
return (id',
GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1) m' insts')
return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' defs' poss1)
mkModRes id mtyp body = do
id' <- transIdent id
case body of
MReuse c -> do
c' <- transIdent c
mtyp' <- trMReuseType mtyp c'
return (transResDef, GM.MTReuse mtyp', id')
_ -> return (transResDef, mtyp, id')
trMReuseType mtyp c = case mtyp of
GM.MTInterface -> return $ GM.MRInterface c
GM.MTInstance op -> return $ GM.MRInstance c op
GM.MTResource -> return $ GM.MRResource c
return (transResDef, mtyp, id')
transComplMod :: ComplMod -> GM.ModuleStatus
@@ -164,13 +141,6 @@ transComplMod x = case x of
getTopDefs :: [TopDef] -> [TopDef]
getTopDefs x = x
transConcSpec :: ConcSpec -> Err (GM.MainConcreteSpec Ident)
transConcSpec x = case x of
ConcSpec id concexp -> do
id' <- transIdent id
(m,mi,mo) <- transConcExp concexp
return $ GM.MainConcreteSpec id' m mi mo
transConcExp :: ConcExp ->
Err (Ident, Maybe (GM.OpenSpec Ident),Maybe (GM.OpenSpec Ident))
transConcExp x = case x of
@@ -205,15 +175,9 @@ transOpens x = case x of
transOpen :: Open -> Err (GM.OpenSpec Ident)
transOpen x = case x of
OName id -> liftM (GM.OSimple GM.OQNormal) $ transIdent id
OQualQO q id -> liftM2 GM.OSimple (transQualOpen q) (transIdent id)
OQual q id m -> liftM3 GM.OQualif (transQualOpen q) (transIdent id) (transIdent m)
transQualOpen :: QualOpen -> Err GM.OpenQualif
transQualOpen x = case x of
QOCompl -> return GM.OQNormal
QOInterface -> return GM.OQInterface
QOIncompl -> return GM.OQIncomplete
OName id -> liftM GM.OSimple (transIdent id)
OQualQO q id -> liftM GM.OSimple (transIdent id)
OQual q id m -> liftM2 GM.OQualif (transIdent id) (transIdent m)
transIncluded :: Included -> Err (Ident,[Ident])
transIncluded x = case x of
@@ -261,9 +225,6 @@ transAbsDef x = case x of
returnl $
[(c, nopos, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++
[(f, nopos, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf]
DefTrans defs -> do
defs' <- liftM concat $ mapM getDefsGen defs
returnl [(c, nopos, G.AbsTrans f) | ((c,p),(_,Yes f)) <- defs']
DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs
_ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
where