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
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
|
----------------------------------------------------------------------
-- |
-- Module : GF.Grammar.Printer
-- Maintainer : Krasimir Angelov
-- Stability : (stable)
-- Portability : (portable)
--
-----------------------------------------------------------------------------
module GF.Grammar.Printer
( TermPrintQual(..)
, ppLabel
, ppGrammar
, ppModule
, ppJudgement
, ppParams
, ppTerm
, ppPatt
, ppValue
, ppConstrs
, ppLocation
, ppQIdent
, ppMeta
, getAbs
) where
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.Values
import GF.Grammar.Grammar
import PGF.Expr (ppMeta)
import PGF.Printer (ppFId, ppFunId, ppSeqId, ppSeq)
import Text.PrettyPrint
import Data.Maybe (maybe, isNothing)
import Data.List (intersperse)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
import qualified Data.Array.IArray as Array
data TermPrintQual
= Unqualified | Qualified | Internal
deriving Eq
ppGrammar :: SourceGrammar -> Doc
ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr
ppModule :: TermPrintQual -> SourceModule -> Doc
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
hdr $$
nest 2 (ppOptions opts $$
vcat (map (ppJudgement q) (Map.toList jments)) $$
maybe empty (ppSequences q) mseqs) $$
ftr
where
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 ie -> text "instance" <+> ppIdent mn <+> text "of" <+> ppExtends ie
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 ) =
text "cat" <+> ppIdent id <+>
(case pcont of
Just (L _ cont) -> hsep (map (ppDecl q) cont)
Nothing -> empty) <+> semi
ppJudgement q (id, AbsFun ptype _ pexp poper) =
let kind | isNothing pexp = "data"
| poper == Just False = "oper"
| otherwise = "fun"
in
(case ptype of
Just (L _ typ) -> text kind <+> 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 | L _ (ps,e) <- eqs]
Nothing -> empty)
ppJudgement q (id, ResParam pparams _) =
text "param" <+> ppIdent id <+>
(case pparams of
Just (L _ ps) -> equals <+> ppParams q ps
_ -> empty) <+> semi
ppJudgement q (id, ResValue pvalue) =
text "-- param constructor" <+> ppIdent id <+> colon <+>
(case pvalue of
(L _ ty) -> ppTerm q 0 ty) <+> semi
ppJudgement q (id, ResOper ptype pexp) =
text "oper" <+> ppIdent id <+>
(case ptype of {Just (L _ t) -> colon <+> ppTerm q 0 t; Nothing -> empty} $$
case pexp of {Just (L _ 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 <+> semi) | (L _ ty,L _ e) <- defs]) $$
rbrace) <+> semi
ppJudgement q (id, CncCat ptype pexp pprn mpmcfg) =
(case ptype of
Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi
Nothing -> empty) $$
(case pexp of
Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
Nothing -> empty) $$
(case pprn of
Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
Nothing -> empty) $$
(case (mpmcfg,q) of
(Just (PMCFG prods funs),Internal)
-> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$
nest 2 (vcat (map ppProduction prods) $$
space $$
vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+>
parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))
(Array.assocs funs))) $$
char '}'
_ -> empty)
ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
(case pdef of
Just (L _ 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 (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
Nothing -> empty) $$
(case (mpmcfg,q) of
(Just (PMCFG prods funs),Internal)
-> text "pmcfg" <+> ppIdent id <+> equals <+> char '{' $$
nest 2 (vcat (map ppProduction prods) $$
space $$
vcat (map (\(funid,arr) -> ppFunId funid <+> text ":=" <+>
parens (hcat (punctuate comma (map ppSeqId (Array.elems arr)))))
(Array.assocs funs))) $$
char '}'
_ -> empty)
ppJudgement q (id, AnyInd cann mid) =
case q of
Internal -> text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi
_ -> empty
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 <+> brackets (fsep (punctuate semi (map (ppTerm q 0) es)))
ppTerm q d (FV es) = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
ppTerm q d (Alts e xs) = prec d 4 (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 id) = ppQIdent q id
ppTerm q d (QC id) = ppQIdent q id
ppTerm q d (Sort id) = ppIdent id
ppTerm q d (K s) = str s
ppTerm q d (EInt n) = int n
ppTerm q d (EFloat f) = double f
ppTerm q d (Meta i) = ppMeta i
ppTerm q d (Empty) = text "[]"
ppTerm q d (R []) = text "<>" -- to distinguish from {} empty RecType
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 '>'
ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
ppTerm q d (ELincat cat t) = prec d 4 (text "lincat" <+> ppIdent cat <+> ppTerm q 5 t)
ppTerm q d (ELin cat t) = prec d 4 (text "lin" <+> ppIdent cat <+> ppTerm q 5 t)
ppTerm q d (Error s) = prec d 4 (text "Predef.error" <+> str s)
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 3) ps))
ppPatt q d (PP f ps) = if null ps
then ppQIdent q f
else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> char '*')
ppPatt q d (PAs f p) = prec d 2 (ppIdent f <> char '@' <> ppPatt q 3 p)
ppPatt q d (PNeg p) = prec d 2 (char '-' <> ppPatt q 3 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 id) = char '#' <> ppQIdent q id
ppPatt q d PW = char '_'
ppPatt q d (PV id) = ppIdent id
ppPatt q d (PInt n) = int 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]))
ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
ppPatt q d (PTilde t) = prec d 2 (char '~' <> ppTerm q 6 t)
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 3 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)
ppQIdent q (m,id) =
case q of
Unqualified -> ppIdent id
Qualified -> ppIdent m <> char '.' <> ppIdent id
Internal -> ppIdent m <> char '.' <> 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
ppParams q ps = fsep (intersperse (char '|') (map (ppParam q) ps))
ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
ppLocation :: FilePath -> Location -> Doc
ppLocation fpath NoLoc = text fpath
ppLocation fpath (External p l) = ppLocation p l
ppLocation fpath (Local b e)
| b == e = text fpath <> colon <> int b
| otherwise = text fpath <> colon <> int b <> text "-" <> int e
ppProduction (Production fid funid args) =
ppFId fid <+> text "->" <+> ppFunId funid <>
brackets (hcat (punctuate comma (map (hsep . intersperse (char '|') . map ppFId) args)))
ppSequences q seqsArr
| null seqs || q /= Internal = empty
| otherwise = text "sequences" <+> char '{' $$
nest 2 (vcat (map ppSeq seqs)) $$
char '}'
where
seqs = Array.assocs seqsArr
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)
|
