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
|
module GF.GFCC.Raw.ConvertGFCC (toGFCC,fromGFCC) where
import GF.GFCC.DataGFCC
import GF.GFCC.Raw.AbsGFCCRaw
import Data.Map
-- convert parsed grammar to internal GFCC
toGFCC :: Grammar -> GFCC
toGFCC (Grm [
AId a,
App (CId "concrete") cs,
App (CId "flags") gfs,
ab@(
App (CId "abstract") [
App (CId "flags") afls,
App (CId "fun") fs,
App (CId "cat") cts
]),
App (CId "concrete") ccs
]) = GFCC {
absname = a,
cncnames = [c | AId c <- cs],
gflags = fromAscList [(f,v) | App f [AStr v] <- gfs],
abstract =
let
aflags = fromAscList [(f,v) | App f [AStr v] <- afls]
lfuns = [(f,(toType typ,toExp def)) | App f [typ, def] <- fs]
funs = fromAscList lfuns
lcats = [(c, Prelude.map toHypo hyps) | App c hyps <- cts]
cats = fromAscList lcats
catfuns = fromAscList
[(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
in Abstr aflags funs cats catfuns,
concretes = fromAscList (lmap mkCnc ccs)
}
where
mkCnc (
App lang [
App (CId "flags") fls,
App (CId "lin") ls,
App (CId "oper") ops,
App (CId "lincat") lincs,
App (CId "lindef") linds,
App (CId "printname") prns,
App (CId "param") params
]) = (lang,
Concr {
cflags = fromAscList [(f,v) | App f [AStr v] <- afls],
lins = fromAscList [(f,toTerm v) | App f [v] <- ls],
opers = fromAscList [(f,toTerm v) | App f [v] <- ops],
lincats = fromAscList [(f,toTerm v) | App f [v] <- lincs],
lindefs = fromAscList [(f,toTerm v) | App f [v] <- linds],
printnames = fromAscList [(f,toTerm v) | App f [v] <- prns],
paramlincats = fromAscList [(f,toTerm v) | App f [v] <- params]
}
)
toType :: RExp -> Type
toType e = case e of
App cat [App (CId "H") hypos, App (CId "X") exps] ->
DTyp (lmap toHypo hypos) cat (lmap toExp exps)
_ -> error $ "type " ++ show e
toHypo :: RExp -> Hypo
toHypo e = case e of
App x [typ] -> Hyp x (toType typ)
_ -> error $ "hypo " ++ show e
toExp :: RExp -> Exp
toExp e = case e of
App fun [App (CId "B") xs, App (CId "X") exps] ->
DTr [x | AId x <- xs] (AC fun) (lmap toExp exps)
App (CId "Eq") eqs ->
EEq [Equ (lmap toExp ps) (toExp v) | App (CId "E") (v:ps) <- eqs]
AMet -> DTr [] (AM 0) []
AInt i -> DTr [] (AI i) []
AFlt i -> DTr [] (AF i) []
AStr i -> DTr [] (AS i) []
AId i -> DTr [] (AV i) []
_ -> error $ "exp " ++ show e
toTerm :: RExp -> Term
toTerm e = case e of
App (CId "R") es -> R (lmap toTerm es)
App (CId "S") es -> S (lmap toTerm es)
App (CId "FV") es -> FV (lmap toTerm es)
App (CId "P") [e,v] -> P (toTerm e) (toTerm v)
App (CId "RP") [e,v] -> RP (toTerm e) (toTerm v) ----
App (CId "W") [AStr s,v] -> W s (toTerm v)
AInt i -> C (fromInteger i)
AMet -> TM
AId f -> F f
App (CId "A") [AInt i] -> V (fromInteger i)
AStr s -> K (KS s) ----
_ -> error $ "term " ++ show e
------------------------------
--- from internal to parser --
------------------------------
fromGFCC :: GFCC -> Grammar
fromGFCC gfcc0 = Grm [
AId (absname gfcc),
app "concrete" (lmap AId (cncnames gfcc)),
app "flags" [App f [AStr v] | (f,v) <- toList (gflags gfcc)],
app "abstract" [
app "flags" [App f [AStr v] | (f,v) <- toList (aflags agfcc)],
app "fun" [App f [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)],
app "cat" [App f (lmap fromHypo hs) | (f,hs) <- toList (cats agfcc)]
],
app "concrete" [App lang (fromConcrete c) | (lang,c) <- toList (concretes gfcc)]
]
where
gfcc = utf8GFCC gfcc0
app s = App (CId s)
agfcc = abstract gfcc
fromConcrete cnc = [
app "flags" [App f [AStr v] | (f,v) <- toList (cflags cnc)],
app "lin" [App f [fromTerm v] | (f,v) <- toList (lins cnc)],
app "oper" [App f [fromTerm v] | (f,v) <- toList (opers cnc)],
app "lincat" [App f [fromTerm v] | (f,v) <- toList (lincats cnc)],
app "lindef" [App f [fromTerm v] | (f,v) <- toList (lindefs cnc)],
app "printname" [App f [fromTerm v] | (f,v) <- toList (printnames cnc)],
app "param" [App f [fromTerm v] | (f,v) <- toList (paramlincats cnc)]
]
fromType :: Type -> RExp
fromType e = case e of
DTyp hypos cat exps ->
App cat [
App (CId "H") (lmap fromHypo hypos),
App (CId "X") (lmap fromExp exps)]
fromHypo :: Hypo -> RExp
fromHypo e = case e of
Hyp x typ -> App x [fromType typ]
fromExp :: Exp -> RExp
fromExp e = case e of
DTr xs (AC fun) exps ->
App fun [App (CId "B") (lmap AId xs), App (CId "X") (lmap fromExp exps)]
DTr [] (AS s) [] -> AStr s
DTr [] (AF d) [] -> AFlt d
DTr [] (AV x) [] -> AId x
DTr [] (AI i) [] -> AInt (toInteger i)
DTr [] (AM _) [] -> AMet ----
EEq eqs ->
App (CId "Eq") [App (CId "E") (lmap fromExp (v:ps)) | Equ ps v <- eqs]
_ -> error $ "exp " ++ show e
fromTerm :: Term -> RExp
fromTerm e = case e of
R es -> app "R" (lmap fromTerm es)
S es -> app "S" (lmap fromTerm es)
FV es -> app "FV" (lmap fromTerm es)
P e v -> app "P" [fromTerm e, fromTerm v]
RP e v -> app "RP" [fromTerm e, fromTerm v] ----
W s v -> app "W" [AStr s, fromTerm v]
C i -> AInt (toInteger i)
TM -> AMet
F f -> AId f
V i -> App (CId "A") [AInt (toInteger i)]
K (KS s) -> AStr s ----
K (KP d vs) -> app "FV" (str d : [str v | Var v _ <- vs]) ----
where
app = App . CId
str v = app "S" (lmap AStr v)
|
