1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
----------------------------------------------------------------------
-- |
-- Module : CanonToGrammar
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/06/17 14:15:17 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.15 $
--
-- a decompiler. AR 12/6/2003 -- 19/4/2004
-----------------------------------------------------------------------------
module GF.Canon.CanonToGrammar (canon2sourceGrammar, canon2sourceModule, redFlag) where
import GF.Canon.AbsGFC
import GF.Canon.GFC
import GF.Canon.MkGFC
---import CMacros
import qualified GF.Infra.Modules as M
import qualified GF.Infra.Option as O
import qualified GF.Grammar.Grammar as G
import qualified GF.Grammar.Macros as F
import GF.Infra.Ident
import GF.Data.Operations
import Control.Monad
canon2sourceGrammar :: CanonGrammar -> Err G.SourceGrammar
canon2sourceGrammar gr = do
ms' <- mapM canon2sourceModule $ M.modules gr
return $ M.MGrammar ms'
canon2sourceModule :: CanonModule -> Err G.SourceModule
canon2sourceModule (i,mi) = do
i' <- redIdent i
info' <- case mi of
M.ModMod m -> do
(e,os) <- redExtOpen m
flags <- mapM redFlag $ M.flags m
(abstr,mt) <- case M.mtype m of
M.MTConcrete a -> do
a' <- redIdent a
return (a', M.MTConcrete a')
M.MTAbstract -> return (i',M.MTAbstract) --- c' not needed
M.MTResource -> return (i',M.MTResource) --- c' not needed
M.MTTransfer x y -> return (i',M.MTTransfer x y) --- c' not needed
defs <- mapMTree redInfo $ M.jments m
return $ M.ModMod $ M.Module mt (M.mstatus m) flags e os defs
_ -> Bad $ "cannot decompile module type"
return (i',info')
where
redExtOpen m = do
e' <- return $ M.extend m
os' <- mapM (\ (M.OSimple q i) -> liftM (\i -> M.OQualif q i i) (redIdent i)) $
M.opens m
return (e',os')
redInfo :: (Ident,Info) -> Err (Ident,G.Info)
redInfo (c,info) = errIn ("decompiling abstract" +++ show c) $ do
c' <- redIdent c
info' <- case info of
AbsCat cont fs -> do
return $ G.AbsCat (Yes cont) (Yes (map (uncurry G.Q) fs))
AbsFun typ df -> do
return $ G.AbsFun (Yes typ) (Yes df)
AbsTrans t -> do
return $ G.AbsTrans t
ResPar par -> 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
ppr' <- redCTerm ppr
return $ G.CncCat (Yes ty') (Yes trm') (Yes ppr')
CncFun (CIQ abstr cat) xx body ppr -> do
xx' <- mapM redArgVar xx
body' <- redCTerm body
ppr' <- redCTerm ppr
cat' <- redIdent cat
return $ G.CncFun (Just (cat', ([],F.typeStr))) -- Nothing
(Yes (F.mkAbs xx' body')) (Yes ppr')
AnyInd b c -> liftM (G.AnyInd b) $ redIdent c
return (c',info')
redQIdent :: CIdent -> Err G.QIdent
redQIdent (CIQ m c) = liftM2 (,) (redIdent m) (redIdent c)
redIdent :: Ident -> Err Ident
redIdent = return
redFlag :: Flag -> Err O.Option
redFlag (Flg f x) = return $ O.Opt (prIdent f,[prIdent x])
redDecl :: Decl -> Err G.Decl
redDecl (Decl x a) = liftM2 (,) (redIdent x) (redTerm a)
redType :: Exp -> Err G.Type
redType = redTerm
redTerm :: Exp -> Err G.Term
redTerm t = return $ trExp t
-- resource
redParam (ParD c cont) = do
c' <- redIdent c
cont' <- mapM redCType cont
return $ (c', [(IW,t) | t <- cont'])
-- concrete syntax
redCType :: CType -> Err G.Type
redCType t = case t of
RecType lbs -> do
let (ls,ts) = unzip [(l,t) | Lbg l t <- lbs]
ls' = map redLabel ls
ts' <- mapM redCType ts
return $ G.RecType $ zip ls' ts'
Table p v -> liftM2 G.Table (redCType p) (redCType v)
Cn mc -> liftM (uncurry G.QC) $ redQIdent mc
TStr -> return $ F.typeStr
TInts i -> return $ F.typeInts (fromInteger i)
redCTerm :: Term -> Err G.Term
redCTerm x = case x of
Arg argvar -> liftM G.Vr $ redArgVar argvar
I cident -> liftM (uncurry G.Q) $ redQIdent cident
Par cident terms -> liftM2 F.mkApp
(liftM (uncurry G.QC) $ redQIdent cident)
(mapM redCTerm terms)
LI id -> liftM G.Vr $ redIdent id
R assigns -> do
let (ls,ts) = unzip [(l,t) | Ass l t <- assigns]
let ls' = map redLabel ls
ts' <- mapM redCTerm ts
return $ G.R [(l,(Nothing,t)) | (l,t) <- zip ls' ts']
P term label -> liftM2 G.P (redCTerm term) (return $ redLabel label)
T ctype cases -> do
ctype' <- redCType ctype
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.TComp ctype'
return $ G.T tinfo $ zip ps' ts'
V ctype ts -> do
ctype' <- redCType ctype
ts' <- mapM redCTerm ts
return $ G.V ctype' ts'
S term0 term -> liftM2 G.S (redCTerm term0) (redCTerm term)
C term0 term -> liftM2 G.C (redCTerm term0) (redCTerm term)
FV terms -> liftM G.FV $ mapM redCTerm terms
K (KS str) -> return $ G.K str
EInt i -> return $ G.EInt i
EFloat i -> return $ G.EFloat i
E -> return $ G.Empty
K (KP d vs) -> return $
G.Alts (tList d,[(tList s, G.Strs $ map G.K v) | Var s v <- vs])
where
tList ss = case ss of --- this should be in Macros
[] -> G.Empty
_ -> foldr1 G.C $ map G.K ss
failure x = Bad $ "not yet" +++ show x ----
redArgVar :: ArgVar -> Err Ident
redArgVar x = case x of
A x i -> return $ IA (prIdent x, fromInteger i)
AB x b i -> return $ IAV (prIdent x, fromInteger b, fromInteger i)
redLabel :: Label -> G.Label
redLabel (L x) = G.LIdent $ prIdent x
redLabel (LV i) = G.LVar $ fromInteger i
redPatt :: Patt -> Err G.Patt
redPatt p = case p of
PV x -> liftM G.PV $ redIdent x
PC mc ps -> do
(m,c) <- redQIdent mc
liftM (G.PP m c) (mapM redPatt ps)
PR rs -> do
let (ls,ts) = unzip [(l,t) | PAss l t <- rs]
ls' = map redLabel ls
ts <- mapM redPatt ts
return $ G.PR $ zip ls' ts
PI i -> return $ G.PInt i
PF i -> return $ G.PFloat i
_ -> Bad $ "cannot recompile pattern" +++ show p
|
