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
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
|
----------------------------------------------------------------------
-- |
-- Module : MkGFC
-- Maintainer : AR
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/09/04 11:45:38 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.16 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Canon.MkGFC (prCanonModInfo, prCanon, prCanonMGr,
canon2grammar, grammar2canon, -- buildCanonGrammar,
info2mod,info2def,
trExp, rtExp, rtQIdent) where
import GF.Canon.GFC
import GF.Canon.AbsGFC
import qualified GF.Grammar.Abstract as A
import GF.Grammar.PrGrammar
import GF.Infra.Ident
import GF.Data.Operations
import qualified GF.Infra.Modules as M
prCanonModInfo :: CanonModule -> String
prCanonModInfo = prt . info2mod
prCanon :: CanonGrammar -> String
prCanon = unlines . map prCanonModInfo . M.modules
prCanonMGr :: CanonGrammar -> String
prCanonMGr g = header ++++ prCanon g where
header = case M.greatestAbstract g of
Just a -> prt (MGr (M.allConcretes g a) a [])
_ -> []
canon2grammar :: Canon -> CanonGrammar
canon2grammar (MGr _ _ modules) = canon2grammar (Gr modules) ---- ignoring the header
canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules
mod2info m = case m of
Mod mt e os flags defs ->
let defs' = buildTree $ map def2info defs
(a,mt') = case mt of
MTAbs a -> (a,M.MTAbstract)
MTRes a -> (a,M.MTResource)
MTCnc a x -> (a,M.MTConcrete x)
MTTrans a x y -> (a,M.MTTransfer (M.oSimple x) (M.oSimple y))
in (a,M.ModMod (M.Module mt' M.MSComplete flags (ee e) (oo os) defs'))
where
ee (Ext m) = map M.inheritAll m
ee _ = []
oo (Opens ms) = map M.oSimple ms
oo _ = []
grammar2canon :: CanonGrammar -> Canon
grammar2canon (M.MGrammar modules) = Gr $ map info2mod modules
info2mod :: (Ident, M.ModInfo Ident Flag Info) -> Module
info2mod m = case m of
(a, M.ModMod (M.Module mt _ flags me os defs)) ->
let defs' = map info2def $ tree2list defs
mt' = case mt of
M.MTAbstract -> MTAbs a
M.MTResource -> MTRes a
M.MTConcrete x -> MTCnc a x
M.MTTransfer (M.OSimple _ x) (M.OSimple _ y) -> MTTrans a x y
in
Mod mt' (gfcE me) (gfcO os) flags defs'
where
gfcE = ifNull NoExt Ext . map fst
gfcO os = if null os then NoOpens else Opens [m | M.OSimple _ m <- os]
-- these translations are meant to be trivial
defs2infos = sorted2tree . map def2info
def2info d = case d of
AbsDCat c cont fs -> (c,AbsCat (trCont cont) (trFs fs))
AbsDFun c ty df -> (c,AbsFun (trExp ty) (trExp df))
AbsDTrans c t -> (c,AbsTrans (trExp t))
ResDPar c df -> (c,ResPar df)
ResDOper c ty df -> (c,ResOper ty df)
CncDCat c ty df pr -> (c, CncCat ty df pr)
CncDFun f c xs li pr -> (f, CncFun c xs li pr)
AnyDInd c b m -> (c, AnyInd (b == Canon) m)
-- from file to internal
trCont cont = [(x,trExp t) | Decl x t <- cont]
trFs = map trQIdent
trExp :: Exp -> A.Term
trExp t = case t of
EProd x a b -> A.Prod x (trExp a) (trExp b)
EAbs x b -> A.Abs x (trExp b)
EApp f a -> A.App (trExp f) (trExp a)
EEq eqs -> A.Eqs [(map trPt ps, trExp e) | Equ ps e <- eqs]
EData -> A.EData
_ -> trAt t
where
trAt (EAtom t) = case t of
AC c -> (uncurry A.Q) $ trQIdent c
AD c -> (uncurry A.QC) $ trQIdent c
AV v -> A.Vr v
AM i -> A.Meta $ A.MetaSymb $ fromInteger i
AT s -> A.Sort $ prt s
AS s -> A.K s
AI i -> A.EInt $ i
AF i -> A.EFloat $ i
trPt p = case p of
APC mc ps -> let (m,c) = trQIdent mc in A.PP m c (map trPt ps)
APV x -> A.PV x
APS s -> A.PString s
API i -> A.PInt $ i
APF i -> A.PFloat $ i
APW -> A.PW
trQIdent (CIQ m c) = (m,c)
-- from internal to file
infos2defs = map info2def . tree2list
info2def d = case d of
(c,AbsCat cont fs) -> AbsDCat c (rtCont cont) (rtFs fs)
(c,AbsFun ty df) -> AbsDFun c (rtExp ty) (rtExp df)
(c,AbsTrans t) -> AbsDTrans c (rtExp t)
(c,ResPar df) -> ResDPar c df
(c,ResOper ty df) -> ResDOper c ty df
(c,CncCat ty df pr) -> CncDCat c ty df pr
(f,CncFun c xs li pr) -> CncDFun f c xs li pr
(c,AnyInd b m) -> AnyDInd c (if b then Canon else NonCan) m
rtCont cont = [Decl (rtIdent x) (rtExp t) | (x,t) <- cont]
rtFs = map rtQIdent
rtExp :: A.Term -> Exp
rtExp t = case t of
A.Prod x a b -> EProd (rtIdent x) (rtExp a) (rtExp b)
A.Abs x b -> EAbs (rtIdent x) (rtExp b)
A.App f a -> EApp (rtExp f) (rtExp a)
A.Eqs eqs -> EEq [Equ (map rtPt ps) (rtExp e) | (ps,e) <- eqs]
A.EData -> EData
_ -> EAtom $ rtAt t
where
rtAt t = case t of
A.Q m c -> AC $ rtQIdent (m,c)
A.QC m c -> AD $ rtQIdent (m,c)
A.Vr v -> AV v
A.Meta i -> AM $ toInteger $ A.metaSymbInt i
A.Sort "Type" -> AT SType
A.K s -> AS s
A.EInt i -> AI $ toInteger i
_ -> error $ "MkGFC.rt not defined for" +++ show t
rtPt p = case p of
A.PP m c ps -> APC (rtQIdent (m,c)) (map rtPt ps)
A.PV x -> APV x
A.PString s -> APS s
A.PInt i -> API $ toInteger i
A.PW -> APW
_ -> error $ "MkGFC.rt not defined for" +++ show p
rtQIdent :: (Ident, Ident) -> CIdent
rtQIdent (m,c) = CIQ (rtIdent m) (rtIdent c)
rtIdent x
| isWildIdent x = identC "h_" --- needed in declarations
| otherwise = identC $ prt x ---
{-
-- the following is called in GetGFC to read gfc files line
-- by line. It does not save memory, though, and is therefore
-- not used.
buildCanonGrammar :: Int -> CanonGrammar -> Line -> (CanonGrammar,Int)
buildCanonGrammar n gr0 line = mgr $ case line of
-- LMulti ids id
LHeader mt ext op -> newModule mt ext op
LFlag f@(Flg (IC "modulesize") (IC n)) -> initModule f $ read $ tail n
LFlag flag -> newFlag flag
LDef def -> newDef $ def2info def
-- LEnd -> cleanNames
_ -> M.modules gr0
where
newModule mt ext op = mod2info (Mod mt ext op [] []) : mods
initModule f i = case actm of
(name, M.ModMod (M.Module mt com flags ee oo defs)) ->
(name, M.ModMod (M.Module mt com (f:flags) ee oo (newtree i))) : tmods
newFlag f = case actm of
(name, M.ModMod (M.Module mt com flags ee oo defs)) ->
(name, M.ModMod (M.Module mt com (f:flags) ee oo defs)) : tmods
newDef d = case actm of
(name, M.ModMod (M.Module mt com flags ee oo defs)) ->
(name, M.ModMod (M.Module mt com flags ee oo
(upd (padd 8 n) d defs))) : tmods
-- cleanNames = case actm of
-- (name, M.ModMod (M.Module mt com flags ee oo defs)) ->
-- (name, M.ModMod (M.Module mt com (reverse flags) ee oo
-- (mapTree (\ (IC f,t) -> (IC (drop 8 f),t)) defs))) : tmods
actm = head mods -- only used when a new mod has been created
mods = M.modules gr0
tmods = tail mods
mgr ms = (M.MGrammar ms, case line of
LDef _ -> n+1
LEnd -> 1
_ -> n
)
-- create an initial tree with who-cares value
newtree (i :: Int) = emptyBinTree
-- newtree (i :: Int) = sorted2tree [
-- (padd 8 k, ResPar []) |
-- k <- [1..i]] --- padd (length (show i))
padd l k = 0
-- padd l k = let sk = show k in identC (replicate (l - length sk) '0' ++ sk)
upd _ d defs = updateTree d defs
-- upd n d@(f,t) defs = case defs of
-- NT -> BT (merg n f,t) NT NT --- should not happen
-- BT c@(a,_) left right
-- | n < a -> let left' = upd n d left in BT c left' right
-- | n > a -> let right' = upd n d right in BT c left right'
-- | otherwise -> BT (merg n f,t) left right
-- merg (IC n) (IC f) = IC (n ++ f)
-}
|
