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
|
----------------------------------------------------------------------
-- |
-- Module : GF.Grammar.Printer
-- Maintainer : Krasimir Angelov
-- Stability : (stable)
-- Portability : (portable)
--
-----------------------------------------------------------------------------
module GF.Grammar.Printer
( ppModule
, ppJudgement
, ppTerm
, ppPatt
) where
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Infra.Option
import GF.Grammar.Grammar
import GF.Data.Operations
import Text.PrettyPrint
import Data.Maybe (maybe)
import Data.List (intersperse)
ppModule :: SourceModule -> Doc
ppModule (mn, ModInfo mtype mstat opts exts with opens jments _) =
(let defs = tree2list jments
in if null defs
then hdr
else hdr <+> lbrace $$ nest 2 (ppOptions opts $$ vcat (map ppJudgement defs)) $$ rbrace)
where
hdr = complModDoc <+> modTypeDoc <+> equals <+>
hsep (intersperse (text "**") $
filter (not . isEmpty) $ [ commaPunct ppExtends exts
, maybe empty ppWith with
, if null opens
then empty
else text "open" <+> commaPunct ppOpenSpec opens <+> text "in"
])
complModDoc =
case mstat of
MSComplete -> empty
MSIncomplete -> text "incomplete"
modTypeDoc =
case mtype of
MTAbstract -> text "abstract" <+> ppIdent mn
MTTransfer src dst -> text "transfer" <+> ppIdent mn <+> colon <+> ppOpenSpec src <+> text "->" <+> ppOpenSpec dst
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 ppOpenSpec opens
ppOptions opts =
text "flags" $$
nest 2 (vcat [text option <+> equals <+> text (show value) <+> semi | (option,value) <- optionsGFO opts])
ppJudgement (id, AbsCat pcont pconstrs) =
text "cat" <+> ppIdent id <+>
(case pcont of
Yes cont -> hsep (map ppDecl cont)
_ -> empty) <+> semi $$
case pconstrs of
Yes costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm 0) costrs)) <+> semi
_ -> empty
ppJudgement (id, AbsFun ptype pexp) =
(case ptype of
Yes typ -> text "fun" <+> ppIdent id <+> colon <+> ppTerm 0 typ <+> semi
_ -> empty) $$
(case pexp of
Yes EData -> empty
Yes (Eqs [(ps,e)]) -> text "def" <+> ppIdent id <+> hcat (map (ppPatt 2) ps) <+> equals <+> ppTerm 0 e <+> semi
Yes exp -> text "def" <+> ppIdent id <+> equals <+> ppTerm 0 exp <+> semi
_ -> empty)
ppJudgement (id, ResParam pparams) =
text "param" <+> ppIdent id <+>
(case pparams of
Yes (ps,_) -> equals <+> fsep (intersperse (char '|') (map ppParam ps))
_ -> empty) <+> semi
ppJudgement (id, ResValue pvalue) = empty
ppJudgement (id, ResOper ptype pexp) =
text "oper" <+> ppIdent id <+>
(case ptype of {Yes t -> colon <+> ppTerm 0 t; _ -> empty} $$
case pexp of {Yes e -> equals <+> ppTerm 0 e; _ -> empty}) <+> semi
ppJudgement (id, ResOverload ids defs) =
text "oper" <+> ppIdent id <+> equals <+>
(text "overload" <+> lbrace $$
nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm 0 ty $$ equals <+> ppTerm 0 e) | (ty,e) <- defs]) $$
rbrace) <+> semi
ppJudgement (id, CncCat ptype pexp pprn) =
(case ptype of
Yes typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm 0 typ <+> semi
_ -> empty) $$
(case pexp of
Yes exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm 0 exp <+> semi
_ -> empty) $$
(case pprn of
Yes prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm 0 prn <+> semi
_ -> empty)
ppJudgement (id, CncFun ptype pdef pprn) =
(case pdef of
Yes e -> let (vs,e') = getAbs e
in text "lin" <+> ppIdent id <+> hsep (map ppIdent vs) <+> equals <+> ppTerm 0 e' <+> semi
_ -> empty) $$
(case pprn of
Yes prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm 0 prn <+> semi
_ -> empty)
ppJudgement (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid
ppTerm d (Abs v e) = let (vs,e') = getAbs e
in prec d 0 (char '\\' <> commaPunct ppIdent (v:vs) <+> text "->" <+> ppTerm 0 e')
ppTerm d (T TRaw xs) = case getCTable (T TRaw xs) of
([],_) -> text "table" <+> lbrace $$
nest 2 (vcat (punctuate semi (map ppCase xs))) $$
rbrace
(vs,e) -> prec d 0 (text "\\\\" <> commaPunct ppIdent vs <+> text "=>" <+> ppTerm 0 e)
ppTerm d (T (TTyped t) xs) = text "table" <+> ppTerm 0 t <+> lbrace $$
nest 2 (vcat (punctuate semi (map ppCase xs))) $$
rbrace
ppTerm d (Prod x a b)= if x == identW
then prec d 0 (ppTerm 4 a <+> text "->" <+> ppTerm 0 b)
else prec d 0 (parens (ppIdent x <+> colon <+> ppTerm 0 a) <+> text "->" <+> ppTerm 0 b)
ppTerm d (Table kt vt)=prec d 0 (ppTerm 3 kt <+> text "=>" <+> ppTerm 0 vt)
ppTerm d (Let l e) = let (ls,e') = getLet e
in prec d 0 (text "let" <+> vcat (map ppLocDef (l:ls)) $$ text "in" <+> ppTerm 0 e')
ppTerm d (Eqs es) = text "fn" <+> lbrace $$
nest 2 (vcat (map (\e -> ppEquation e <+> semi) es)) $$
rbrace
ppTerm d (Example e s)=prec d 0 (text "in" <+> ppTerm 5 e <+> text (show s))
ppTerm d (C e1 e2) = prec d 1 (ppTerm 2 e1 <+> text "++" <+> ppTerm 1 e2)
ppTerm d (Glue e1 e2)= prec d 2 (ppTerm 3 e1 <+> char '+' <+> ppTerm 2 e2)
ppTerm d (S x y) = case x of
T annot xs -> let e = case annot of
TTyped t -> Typed y t
TRaw -> y
in text "case" <+> ppTerm 0 e <+> text "of" <+> lbrace $$
nest 2 (vcat (punctuate semi (map ppCase xs))) $$
rbrace
_ -> prec d 3 (ppTerm 3 x <+> text "!" <+> ppTerm 4 y)
ppTerm d (ExtR x y) = prec d 3 (ppTerm 3 x <+> text "**" <+> ppTerm 4 y)
ppTerm d (App x y) = prec d 4 (ppTerm 4 x <+> ppTerm 5 y)
ppTerm d (V e es) = text "table" <+> ppTerm 6 e <+> lbrace $$
nest 2 (fsep (punctuate semi (map (ppTerm 0) es))) $$
rbrace
ppTerm d (FV es) = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm 0) es)))
ppTerm d (Alts (e,xs))=text "pre" <+> braces (ppTerm 0 e <> semi <+> fsep (punctuate semi (map ppAltern xs)))
ppTerm d (Strs es) = text "strs" <+> braces (fsep (punctuate semi (map (ppTerm 0) es)))
ppTerm d (EPatt p) = prec d 4 (char '#' <+> ppPatt 2 p)
ppTerm d (EPattType t)=prec d 4 (text "pattern" <+> ppTerm 0 t)
ppTerm d (P t l) = prec d 5 (ppTerm 5 t <> char '.' <> ppLabel l)
ppTerm d (Cn id) = ppIdent id
ppTerm d (Vr id) = ppIdent id
ppTerm d (Q m id) = ppIdent m <> char '.' <> ppIdent id
ppTerm d (QC m id) = ppIdent m <> char '.' <> ppIdent id
ppTerm d (Sort id) = ppIdent id
ppTerm d (K s) = text (show s)
ppTerm d (EInt n) = integer n
ppTerm d (EFloat f) = double f
ppTerm d (Meta _) = char '?'
ppTerm d (Empty) = text "[]"
ppTerm d (EData) = text "data"
ppTerm d (R xs) = braces (fsep (punctuate semi [ppLabel l <+>
case mb_t of {Just t -> colon <+> ppTerm 0 t; Nothing -> empty} <+>
equals <+> ppTerm 0 e | (l,(mb_t,e)) <- xs]))
ppTerm d (RecType xs)= braces (fsep (punctuate semi [ppLabel l <+> colon <+> ppTerm 0 t | (l,t) <- xs]))
ppTerm d (Typed e t) = char '<' <> ppTerm 0 e <+> colon <+> ppTerm 0 t <> char '>'
ppEquation (ps,e) = hcat (map (ppPatt 2) ps) <+> text "->" <+> ppTerm 0 e
ppCase (p,e) = ppPatt 0 p <+> text "=>" <+> ppTerm 0 e
ppPatt d (PAlt p1 p2) = prec d 0 (ppPatt 0 p1 <+> char '|' <+> ppPatt 1 p2)
ppPatt d (PSeq p1 p2) = prec d 0 (ppPatt 0 p1 <+> char '+' <+> ppPatt 1 p2)
ppPatt d (PC f ps) = prec d 1 (ppIdent f <+> hsep (map (ppPatt 2) ps))
ppPatt d (PP f g ps) = prec d 1 (ppIdent f <> char '.' <> ppIdent g <+> hsep (map (ppPatt 2) ps))
ppPatt d (PRep p) = prec d 1 (ppPatt 2 p <> char '*')
ppPatt d (PAs f p) = prec d 1 (ppIdent f <> char '@' <> ppPatt 2 p)
ppPatt d (PNeg p) = prec d 1 (char '-' <> ppPatt 2 p)
ppPatt d (PChar) = char '?'
ppPatt d (PChars s) = brackets (text (show s))
ppPatt d (PMacro id) = char '#' <> ppIdent id
ppPatt d (PM m id) = char '#' <> ppIdent m <> char '.' <> ppIdent id
ppPatt d (PV id) = ppIdent id
ppPatt d (PInt n) = integer n
ppPatt d (PFloat f) = double f
ppPatt d (PString s) = text (show s)
ppPatt d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt 0 e | (l,e) <- xs]))
ppDecl (id,typ)
| id == identW = ppTerm 4 typ
| otherwise = parens (ppIdent id <+> colon <+> ppTerm 0 typ)
ppDDecl (id,typ)
| id == identW = ppTerm 6 typ
| otherwise = parens (ppIdent id <+> colon <+> ppTerm 0 typ)
ppIdent = text . prIdent
ppLabel = ppIdent . label2ident
ppOpenSpec (OSimple id) = ppIdent id
ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n)
ppLocDef (id, (mbt, e)) =
ppIdent id <+>
(case mbt of {Just t -> colon <+> ppTerm 0 t; Nothing -> empty} <+> equals <+> ppTerm 0 e) <+> semi
ppAltern (x,y) = ppTerm 0 x <+> char '/' <+> ppTerm 0 y
ppParam (id,cxt) = ppIdent id <+> hsep (map ppDDecl cxt)
commaPunct f ds = (hcat (punctuate comma (map f ds)))
prec d1 d2 doc
| d1 > d2 = parens doc
| otherwise = doc
getAbs :: Term -> ([Ident], Term)
getAbs (Abs v e) = let (vs,e') = getAbs e
in (v:vs,e')
getAbs e = ([],e)
getCTable :: Term -> ([Ident], Term)
getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
in (v: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)
|
