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
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
|
----------------------------------------------------------------------
-- |
-- Module : GF.Grammar.Printer
-- Maintainer : Krasimir Angelov
-- Stability : (stable)
-- Portability : (portable)
--
-----------------------------------------------------------------------------
module GF.Grammar.Printer
( TermPrintQual(..)
, ppIdent
, ppLabel
, ppModule
, ppJudgement
, ppTerm
, ppTermTabular
, ppPatt
, ppValue
, ppConstrs
, showTerm, TermPrintStyle(..)
) where
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Infra.Option
import GF.Grammar.Values
import GF.Grammar.Grammar
import GF.Data.Operations
import Text.PrettyPrint
import Data.Maybe (maybe)
import Data.List (intersperse)
data TermPrintQual = Qualified | Unqualified
ppModule :: TermPrintQual -> SourceModule -> Doc
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ jments _) =
hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr
where
defs = tree2list jments
hdr = complModDoc <+> modTypeDoc <+> equals <+>
hsep (intersperse (text "**") $
filter (not . isEmpty) $ [ commaPunct ppExtends exts
, maybe empty ppWith with
, if null opens
then lbrace
else text "open" <+> commaPunct ppOpenSpec opens <+> text "in" <+> lbrace
])
ftr = rbrace
complModDoc =
case mstat of
MSComplete -> empty
MSIncomplete -> text "incomplete"
modTypeDoc =
case mtype of
MTAbstract -> text "abstract" <+> ppIdent mn
MTResource -> text "resource" <+> ppIdent mn
MTConcrete abs -> text "concrete" <+> ppIdent mn <+> text "of" <+> ppIdent abs
MTInterface -> text "interface" <+> ppIdent mn
MTInstance int -> text "instance" <+> ppIdent mn <+> text "of" <+> ppIdent int
ppExtends (id,MIAll ) = ppIdent id
ppExtends (id,MIOnly incs) = ppIdent id <+> brackets (commaPunct ppIdent incs)
ppExtends (id,MIExcept incs) = ppIdent id <+> char '-' <+> brackets (commaPunct ppIdent incs)
ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppInstSpec opens
ppOptions opts =
text "flags" $$
nest 2 (vcat [text option <+> equals <+> str value <+> semi | (option,value) <- optionsGFO opts])
ppJudgement q (id, AbsCat pcont pconstrs) =
text "cat" <+> ppIdent id <+>
(case pcont of
Just cont -> hsep (map (ppDecl q) cont)
Nothing -> empty) <+> semi $$
case pconstrs of
Just costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm q 0) costrs)) <+> semi
Nothing -> empty
ppJudgement q (id, AbsFun ptype _ pexp) =
(case ptype of
Just typ -> text "fun" <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi
Nothing -> empty) $$
(case pexp of
Just [] -> empty
Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | (ps,e) <- eqs]
Nothing -> empty)
ppJudgement q (id, ResParam pparams _) =
text "param" <+> ppIdent id <+>
(case pparams of
Just ps -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps))
_ -> empty) <+> semi
ppJudgement q (id, ResValue pvalue) = empty
ppJudgement q (id, ResOper ptype pexp) =
text "oper" <+> ppIdent id <+>
(case ptype of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} $$
case pexp of {Just e -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi
ppJudgement q (id, ResOverload ids defs) =
text "oper" <+> ppIdent id <+> equals <+>
(text "overload" <+> lbrace $$
nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (ty,e) <- defs]) $$
rbrace) <+> semi
ppJudgement q (id, CncCat ptype pexp pprn) =
(case ptype of
Just typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi
Nothing -> empty) $$
(case pexp of
Just exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
Nothing -> empty) $$
(case pprn of
Just prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
Nothing -> empty)
ppJudgement q (id, CncFun ptype pdef pprn) =
(case pdef of
Just e -> let (xs,e') = getAbs e
in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi
Nothing -> empty) $$
(case pprn of
Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
Nothing -> empty)
ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi
ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e)
in prec d 0 (char '\\' <> commaPunct ppBind xs <+> text "->" <+> ppTerm q 0 e')
ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
([],_) -> text "table" <+> lbrace $$
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
rbrace
(vs,e) -> prec d 0 (text "\\\\" <> commaPunct ppIdent vs <+> text "=>" <+> ppTerm q 0 e)
ppTerm q d (T (TTyped t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
rbrace
ppTerm q d (T (TComp t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
rbrace
ppTerm q d (T (TWild t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
rbrace
ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
then prec d 0 (ppTerm q 4 a <+> text "->" <+> ppTerm q 0 b)
else prec d 0 (parens (ppBind (bt,x) <+> colon <+> ppTerm q 0 a) <+> text "->" <+> ppTerm q 0 b)
ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> text "=>" <+> ppTerm q 0 vt)
ppTerm q d (Let l e) = let (ls,e') = getLet e
in prec d 0 (text "let" <+> vcat (map (ppLocDef q) (l:ls)) $$ text "in" <+> ppTerm q 0 e')
ppTerm q d (Example e s)=prec d 0 (text "in" <+> ppTerm q 5 e <+> str s)
ppTerm q d (C e1 e2) =prec d 1 (ppTerm q 2 e1 <+> text "++" <+> ppTerm q 1 e2)
ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> char '+' <+> ppTerm q 2 e2)
ppTerm q d (S x y) = case x of
T annot xs -> let e = case annot of
TRaw -> y
TTyped t -> Typed y t
TComp t -> Typed y t
TWild t -> Typed y t
in text "case" <+> ppTerm q 0 e <+> text "of" <+> lbrace $$
nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
rbrace
_ -> prec d 3 (ppTerm q 3 x <+> text "!" <+> ppTerm q 4 y)
ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> text "**" <+> ppTerm q 4 y)
ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
ppTerm q d (V e es) = text "table" <+> ppTerm q 6 e <+> lbrace $$
nest 2 (fsep (punctuate semi (map (ppTerm q 0) es))) $$
rbrace
ppTerm q d (FV es) = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
ppTerm q d (Alts (e,xs))=text "pre" <+> braces (ppTerm q 0 e <> semi <+> fsep (punctuate semi (map (ppAltern q) xs)))
ppTerm q d (Strs es) = text "strs" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
ppTerm q d (EPatt p) = prec d 4 (char '#' <+> ppPatt q 2 p)
ppTerm q d (EPattType t)=prec d 4 (text "pattern" <+> ppTerm q 0 t)
ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> char '.' <> ppLabel l)
ppTerm q d (Cn id) = ppIdent id
ppTerm q d (Vr id) = ppIdent id
ppTerm q d (Q m id) = ppQIdent q m id
ppTerm q d (QC m id) = ppQIdent q m id
ppTerm q d (Sort id) = ppIdent id
ppTerm q d (K s) = str s
ppTerm q d (EInt n) = integer n
ppTerm q d (EFloat f) = double f
ppTerm q d (Meta _) = char '?'
ppTerm q d (Empty) = text "[]"
ppTerm q d (R xs) = braces (fsep (punctuate semi [ppLabel l <+>
fsep [case mb_t of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty},
equals <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
ppTerm q d (RecType xs)= braces (fsep (punctuate semi [ppLabel l <+> colon <+> ppTerm q 0 t | (l,t) <- xs]))
ppTerm q d (Typed e t) = char '<' <> ppTerm q 0 e <+> colon <+> ppTerm q 0 t <> char '>'
ppTermTabular :: TermPrintQual -> Term -> [(Doc,Doc)]
ppTermTabular q = pr where
pr t = case t of
R rs ->
[(ppLabel lab <+> char '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val]
T _ cs ->
[(ppPatt q 0 patt <+> text "=>" <+> path, str) | (patt, val ) <- cs, (path,str) <- pr val]
V _ cs ->
[(char '#' <> int i <+> text "=>" <+> path, str) | (i, val ) <- zip [0..] cs, (path,str) <- pr val]
_ -> [(empty,ps t)]
ps t = case t of
K s -> text s
C s u -> ps s <+> ps u
FV ts -> hsep (intersperse (char '/') (map ps ts))
_ -> ppTerm q 0 t
ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> text "->" <+> ppTerm q 0 e
ppCase q (p,e) = ppPatt q 0 p <+> text "=>" <+> ppTerm q 0 e
ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '|' <+> ppPatt q 1 p2)
ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2)
ppPatt q d (PC f ps) = if null ps
then ppIdent f
else prec d 1 (ppIdent f <+> hsep (map (ppPatt q 2) ps))
ppPatt q d (PP f g ps) = if null ps
then ppQIdent q f g
else prec d 1 (ppQIdent q f g <+> hsep (map (ppPatt q 2) ps))
ppPatt q d (PRep p) = prec d 1 (ppPatt q 2 p <> char '*')
ppPatt q d (PAs f p) = prec d 1 (ppIdent f <> char '@' <> ppPatt q 2 p)
ppPatt q d (PNeg p) = prec d 1 (char '-' <> ppPatt q 2 p)
ppPatt q d (PChar) = char '?'
ppPatt q d (PChars s) = brackets (str s)
ppPatt q d (PMacro id) = char '#' <> ppIdent id
ppPatt q d (PM m id) = char '#' <> ppIdent m <> char '.' <> ppIdent id
ppPatt q d PW = char '_'
ppPatt q d (PV id) = ppIdent id
ppPatt q d (PInt n) = integer n
ppPatt q d (PFloat f) = double f
ppPatt q d (PString s) = str s
ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs]))
ppValue :: TermPrintQual -> Int -> Val -> Doc
ppValue q d (VGen i x) = ppIdent x <> text "{-" <> int i <> text "-}" ---- latter part for debugging
ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
ppValue q d (VCn (_,c)) = ppIdent c
ppValue q d (VClos env e) = case e of
Meta _ -> ppTerm q d e <> ppEnv env
_ -> ppTerm q d e ---- ++ prEnv env ---- for debugging
ppValue q d (VRecType xs) = braces (hsep (punctuate comma [ppLabel l <> char '=' <> ppValue q 0 v | (l,v) <- xs]))
ppValue q d VType = text "Type"
ppConstrs :: Constraints -> [Doc]
ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> text "<>" <+> ppValue Unqualified 0 w))
ppEnv :: Env -> Doc
ppEnv e = hcat (map (\(x,t) -> braces (ppIdent x <> text ":=" <> ppValue Unqualified 0 t)) e)
str s = doubleQuotes (text s)
ppDecl q (_,id,typ)
| id == identW = ppTerm q 4 typ
| otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)
ppDDecl q (_,id,typ)
| id == identW = ppTerm q 6 typ
| otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)
ppIdent = text . showIdent
ppQIdent q m id =
case q of
Qualified -> ppIdent m <> char '.' <> ppIdent id
Unqualified -> ppIdent id
ppLabel = ppIdent . label2ident
ppOpenSpec (OSimple id) = ppIdent id
ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n)
ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n)
ppLocDef q (id, (mbt, e)) =
ppIdent id <+>
(case mbt of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} <+> equals <+> ppTerm q 0 e) <+> semi
ppBind (Explicit,v) = ppIdent v
ppBind (Implicit,v) = braces (ppIdent v)
ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y
ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
commaPunct f ds = (hcat (punctuate comma (map f ds)))
prec d1 d2 doc
| d1 > d2 = parens doc
| otherwise = doc
getAbs :: Term -> ([(BindType,Ident)], Term)
getAbs (Abs bt v e) = let (xs,e') = getAbs e
in ((bt,v):xs,e')
getAbs e = ([],e)
getCTable :: Term -> ([Ident], Term)
getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
in (v:vs,e')
getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e
in (identW:vs,e')
getCTable e = ([],e)
getLet :: Term -> ([LocalDef], Term)
getLet (Let l e) = let (ls,e') = getLet e
in (l:ls,e')
getLet e = ([],e)
showTerm :: TermPrintStyle -> TermPrintQual -> Term -> String
showTerm style q t = render $
case style of
TermPrintTable -> vcat [p <+> s | (p,s) <- ppTermTabular q t]
TermPrintAll -> vcat [ s | (p,s) <- ppTermTabular q t]
TermPrintDefault -> ppTerm q 0 t
data TermPrintStyle
= TermPrintTable
| TermPrintAll
| TermPrintDefault
|
