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

fixed a bug on not updating parameter table in record fields in GrammarToGFCC

Browse Source
This commit is contained in:
aarne
2007-11-12 14:30:53 +00:00
parent 6158445114
commit 5d06a31078
1 changed files with 6 additions and 1 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
src/GF/Devel/GrammarToGFCC.hs
View File

@@ -300,7 +300,6 @@ type ParamEnv =
--- gathers those param types that are actually used in lincats and lin terms --- gathers those param types that are actually used in lincats and lin terms
paramValues :: SourceGrammar -> ParamEnv paramValues :: SourceGrammar -> ParamEnv
paramValues cgr = (labels,untyps,typs) where paramValues cgr = (labels,untyps,typs) where
params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps]
partyps = nub $ [ty | partyps = nub $ [ty |
(_,(_,CncCat (Yes (RecType ls)) _ _)) <- jments, (_,(_,CncCat (Yes (RecType ls)) _ _)) <- jments,
ty0 <- [ty | (_, ty) <- unlockTyp ls], ty0 <- [ty | (_, ty) <- unlockTyp ls],
@@ -312,6 +311,7 @@ paramValues cgr = (labels,untyps,typs) where
(_,(_,CncFun _ (Yes tr) _)) <- jments, (_,(_,CncFun _ (Yes tr) _)) <- jments,
ty <- err (const []) snd $ appSTM (typsFromTrm tr) [] ty <- err (const []) snd $ appSTM (typsFromTrm tr) []
] ]
params = [(ty, errVal [] $ Look.allParamValues cgr ty) | ty <- partyps]
typsFrom ty = case ty of typsFrom ty = case ty of
Table p t -> typsFrom p ++ typsFrom t Table p t -> typsFrom p ++ typsFrom t
RecType ls -> RecType (sort (unlockTyp ls)) : concat [typsFrom t | (_, t) <- ls] RecType ls -> RecType (sort (unlockTyp ls)) : concat [typsFrom t | (_, t) <- ls]
@@ -320,6 +320,11 @@ paramValues cgr = (labels,untyps,typs) where
typsFromTrm :: Term -> STM [Type] Term typsFromTrm :: Term -> STM [Type] Term
typsFromTrm tr = case tr of typsFromTrm tr = case tr of
V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr V ty ts -> updateSTM (ty:) >> mapM_ typsFromTrm ts >> return tr
R fs -> mapM_ (typsFromField . snd) fs >> return tr
where
typsFromField (mty, t) = case mty of
Just x -> updateSTM (x:) >> typsFromTrm t
_ -> typsFromTrm t
T (TTyped ty) cs -> T (TTyped ty) cs ->
updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr updateSTM (ty:) >> mapM_ typsFromTrm [t | (_, t) <- cs] >> return tr
T (TComp ty) cs -> T (TComp ty) cs ->