GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

some adjustments in GFCC generation (old)

Browse Source
This commit is contained in:
aarne
2007-12-10 16:46:04 +00:00
parent 3e788e5bbd
commit 77a502085d
2 changed files with 14 additions and 5 deletions
Download Patch File Download Diff File Expand all files Collapse all files

13
src/GF/Canon/CanonToGrammar.hs
View File

@@ -73,6 +73,11 @@ redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do
par' <- mapM redParam par
return $ G.ResParam (Yes (par',Nothing)) ---- list of values
ResOper pty ptr -> do
ty' <- redCType pty
trm' <- redCTerm ptr
return $ G.ResOper (Yes ty') (Yes trm')
CncCat pty ptr ppr -> do
ty' <- redCType pty
trm' <- redCTerm ptr
@@ -145,13 +150,13 @@ redCTerm x = case x of
P term label -> liftM2 G.P (redCTerm term) (return $ redLabel label)
T ctype cases -> do
ctype' <- redCType ctype
let (ps,ts) = unzip [(ps,t) | Cas ps t <- cases]
ps' <- mapM (mapM redPatt) ps
let (ps,ts) = unzip [(p,t) | Cas [p] t <- cases]
ps' <- mapM redPatt ps
ts' <- mapM redCTerm ts
let tinfo = case ps' of
[[G.PV _]] -> G.TTyped ctype'
[G.PV _] -> G.TTyped ctype'
_ -> G.TComp ctype'
return $ G.TSh tinfo $ zip ps' ts'
return $ G.T tinfo $ zip ps' ts'
V ctype ts -> do
ctype' <- redCType ctype
ts' <- mapM redCTerm ts

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

@@ -129,6 +129,7 @@ mkTerm tr = case tr of
EInt i -> C.C $ fromInteger i
R rs -> C.R [mkTerm t | (_, (_,t)) <- rs]
P t l -> C.P (mkTerm t) (C.C (mkLab l))
TSh _ _ -> error $ show tr
T _ cs -> C.R [mkTerm t | (_,t) <- cs] ------
V _ cs -> C.R [mkTerm t | t <- cs]
S t p -> C.P (mkTerm t) (mkTerm p)
@@ -378,6 +379,9 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
(i,(l,(_,t))) <- zip [0..] (sort (unlock rs))]
P t l -> r2r tr
PI t l i -> EInt $ toInteger i
T _ [_] -> error $ "single" +++ prt tr
T (TWild _) _ -> error $ "wild" +++ prt tr
T (TComp ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
T (TTyped ty) cs -> t2t $ V ty $ map snd cs ---- should be elim'ed in tc
V ty ts -> mkCurry $ V ty [t2t t | t <- ts]
@@ -457,7 +461,7 @@ term2term cgr env@(labels,untyps,typs) tr = case tr of
(FV ts,_) -> ts
_ -> [tr]
valNumFV ts = case ts of
[tr] -> trace (unwords (map prt (Map.keys typs))) $
[tr] -> trace (unwords (map prt (Map.keys untyps))) $
prtTrace tr $ K "66667"
_ -> FV $ map valNum ts