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
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
|
{-# LANGUAGE TemplateHaskell, CPP #-}
-- TH.Ppr contains a prettyprinter for the
-- Template Haskell datatypes
module Language.Haskell.TH.FixedPpr where
-- All of the exports from this module should
-- be "public" functions. The main module TH
-- re-exports them all.
import Text.PrettyPrint.HughesPJ (render)
import Language.Haskell.TH.PprLib
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Data(isTupleT)
import Data.Char ( toLower, isAlpha )
nestDepth :: Int
nestDepth = 4
type Precedence = Int
appPrec, opPrec, noPrec :: Precedence
appPrec = 2 -- Argument of a function application
opPrec = 1 -- Argument of an infix operator
noPrec = 0 -- Others
parensIf :: Bool -> Doc -> Doc
parensIf True d = parens d
parensIf False d = d
------------------------------
-- Show name with `` and () stripped, so that behaviour is the same
-- with fixed and broken syntax-libs
showNameRaw :: Name -> String
showNameRaw = clean . show
where
clean ('(':xs) = init xs
clean ('`':xs) = init xs
clean xs = xs
isPrefixName :: Name -> Bool
isPrefixName = classify . showNameRaw
where
classify xs = case break (=='.') xs of
(_,(_:xs')) -> classify xs'
((x:xs),[]) -> isAlpha x || x == '_'
_ -> False -- operators ending with .
pprName_ :: Bool -> Name -> Doc
pprName_ True nm | isPrefixName nm = text (showNameRaw nm)
| otherwise = text ("(" ++ showNameRaw nm ++ ")")
pprName_ False nm | isPrefixName nm = text ("`" ++ showNameRaw nm ++ "`")
| otherwise = text (showNameRaw nm)
------------------------------
pprint :: Ppr a => a -> String
pprint x = render $ to_HPJ_Doc $ ppr x
class Ppr a where
ppr :: a -> Doc
ppr_list :: [a] -> Doc
ppr_list = vcat . map ppr
instance Ppr a => Ppr [a] where
ppr x = ppr_list x
------------------------------
instance Ppr Name where
ppr v = pprName_ True v -- text (show v)
------------------------------
instance Ppr Info where
#if __GLASGOW_HASKELL__ >= 700
ppr (ClassI d _) = ppr d
#else
ppr (ClassI d) = ppr d
#endif
ppr (TyConI d) = ppr d
ppr (PrimTyConI name arity is_unlifted)
= text "Primitive"
<+> (if is_unlifted then text "unlifted" else empty)
<+> text "type construtor" <+> quotes (ppr name)
<+> parens (text "arity" <+> int arity)
ppr (ClassOpI v ty cls fix)
= text "Class op from" <+> ppr cls <> colon <+>
vcat [ppr_sig v ty, pprFixity v fix]
ppr (DataConI v ty tc fix)
= text "Constructor from" <+> ppr tc <> colon <+>
vcat [ppr_sig v ty, pprFixity v fix]
ppr (TyVarI v ty)
= text "Type variable" <+> ppr v <+> equals <+> ppr ty
ppr (VarI v ty mb_d fix)
= vcat [ppr_sig v ty, pprFixity v fix,
case mb_d of { Nothing -> empty; Just d -> ppr d }]
ppr_sig v ty = ppr v <+> text "::" <+> ppr ty
pprFixity :: Name -> Fixity -> Doc
pprFixity v f | f == defaultFixity = empty
pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v
where ppr_fix InfixR = text "infixr"
ppr_fix InfixL = text "infixl"
ppr_fix InfixN = text "infix"
------------------------------
instance Ppr Exp where
ppr = pprExp noPrec
pprExpInfix :: Exp -> Doc
pprExpInfix (VarE v) = pprName_ False v
pprExpInfix (ConE c) = pprName_ False c
pprExp :: Precedence -> Exp -> Doc
pprExp _ (VarE v) = ppr v
pprExp _ (ConE c)
| isTupleT (ConT c) = text (nameBase c)
| c == '[] = text ("[]")
| c == '(:) = text ("(:)")
| otherwise = ppr c
pprExp i (LitE l) = pprLit i l
pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1
<+> pprExp appPrec e2
pprExp i (InfixE (Just e1) op (Just e2))
= parensIf (i >= opPrec) $ pprExp opPrec e1
<+> pprExpInfix op
<+> pprExp opPrec e2
pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1
<+> pprExpInfix op
<+> pprMaybeExp noPrec me2
pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)
<+> text "->" <+> ppr e
pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es
-- Nesting in Cond is to avoid potential problems in do statments
pprExp i (CondE guard true false)
= parensIf (i > noPrec) $ sep [text "if" <+> ppr guard,
nest 1 $ text "then" <+> ppr true,
nest 1 $ text "else" <+> ppr false]
pprExp i (LetE ds e) = parensIf (i > noPrec) $ text "let" <+> ppr ds
$$ text " in" <+> ppr e
pprExp i (CaseE e ms)
= parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"
$$ nest nestDepth (ppr ms)
pprExp i (DoE ss) = parensIf (i > noPrec) $ text "do" <+> ppr ss
pprExp _ (CompE []) = error "Can't happen: pprExp (CompExp [])"
-- This will probably break with fixity declarations - would need a ';'
pprExp _ (CompE ss) = text "[" <> ppr s
<+> text "|"
<+> (sep $ punctuate comma $ map ppr ss')
<> text "]"
where s = last ss
ss' = init ss
pprExp _ (ArithSeqE d) = ppr d
pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es
pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t
pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)
pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
pprFields :: [(Name,Exp)] -> Doc
pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)
pprMaybeExp :: Precedence -> Maybe Exp -> Doc
pprMaybeExp _ Nothing = empty
pprMaybeExp i (Just e) = pprExp i e
------------------------------
instance Ppr Stmt where
ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e
ppr (LetS ds) = text "let" <+> ppr ds
ppr (NoBindS e) = ppr e
ppr (ParS sss) = sep $ punctuate (text "|")
$ map (sep . punctuate comma . map ppr) sss
------------------------------
instance Ppr Match where
ppr (Match p rhs ds) = ppr p <+> pprBody False rhs
$$ where_clause ds
------------------------------
pprBody :: Bool -> Body -> Doc
pprBody eq (GuardedB xs) = nest nestDepth $ vcat $ map do_guard xs
where eqd = if eq then text "=" else text "->"
do_guard (NormalG g, e) = text "|" <+> ppr g <+> eqd <+> ppr e
do_guard (PatG ss, e) = text "|" <+> vcat (map ppr ss)
$$ nest nestDepth (eqd <+> ppr e)
pprBody eq (NormalB e) = (if eq then text "=" else text "->") <+> ppr e
instance Ppr Body where
ppr = pprBody True
------------------------------
pprLit :: Precedence -> Lit -> Doc
pprLit i (IntPrimL x) = parensIf (i > noPrec && x < 0)
(integer x <> char '#')
pprLit i (FloatPrimL x) = parensIf (i > noPrec && x < 0)
(float (fromRational x) <> char '#')
pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)
(double (fromRational x) <> text "##")
pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x)
pprLit _ (CharL c) = text (show c)
pprLit _ (StringL s) = text (show s)
pprLit i (RationalL rat) = parensIf (i > noPrec) $ rational rat
instance Ppr Lit where
ppr = pprLit 10
------------------------------
instance Ppr Pat where
ppr = pprPat noPrec
pprPat :: Precedence -> Pat -> Doc
pprPat i (LitP l) = pprLit i l
pprPat _ (VarP v) = ppr v
pprPat _ (TupP ps) = parens $ sep $ punctuate comma $ map ppr ps
pprPat i (ConP s ps) = parensIf (i > noPrec) $ x
<+> sep (map (pprPat appPrec) ps)
where
x | isTupleT (ConT s) = text (nameBase s)
| s == '[] = text "[]"
| s == '(:) = text "(:)"
| otherwise = ppr s
pprPat i (InfixP p1 n p2)
= parensIf (i > noPrec)
$ pprPat opPrec p1 <+> pprName_ False n <+> pprPat opPrec p2
pprPat i (TildeP p) = parensIf (i > noPrec) $ text "~" <> pprPat appPrec p
pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@"
<> pprPat appPrec p
pprPat _ WildP = text "_"
pprPat _ (RecP nm fs)
= parens $ ppr nm
<+> braces (sep $ punctuate comma $
map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)
pprPat _ (ListP ps) = brackets $ sep $ punctuate comma $ map ppr ps
pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> text "::" <+> ppr t
------------------------------
instance Ppr Dec where
ppr (FunD f cs) = vcat $ map (\c -> ppr f <+> ppr c) cs
ppr (ValD p r ds) = ppr p <+> pprBody True r
$$ where_clause ds
ppr (TySynD t xs rhs) = text "type" <+> ppr t <+> hsep (map ppr xs)
<+> text "=" <+> ppr rhs
ppr (DataD ctxt t xs cs decs)
= text "data"
<+> pprCxt ctxt
<+> ppr t <+> hsep (map ppr xs)
<+> sep (pref $ map ppr cs)
$$ if null decs
then empty
else nest nestDepth
$ text "deriving"
<+> parens (hsep $ punctuate comma $ map ppr decs)
where pref :: [Doc] -> [Doc]
pref [] = [] -- Can't happen in H98
pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds
ppr (NewtypeD ctxt t xs c decs)
= text "newtype"
<+> pprCxt ctxt
<+> ppr t <+> hsep (map ppr xs)
<+> char '=' <+> ppr c
$$ if null decs
then empty
else nest nestDepth
$ text "deriving"
<+> parens (hsep $ punctuate comma $ map ppr decs)
ppr (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt
<+> ppr c <+> hsep (map ppr xs) <+> ppr fds
$$ where_clause ds
ppr (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
$$ where_clause (map deQualLhsHead ds)
ppr (SigD f t) = ppr f <+> text "::" <+> ppr t
ppr (ForeignD f) = ppr f
deQualLhsHead :: Dec -> Dec
deQualLhsHead (FunD n cs) = FunD (deQualName n) cs
deQualLhsHead (ValD p b ds) = ValD (go p) b ds
where
go (VarP n) = VarP (deQualName n)
go (InfixP p1 n p2) = InfixP p1 (deQualName n) p2
go x = x
deQualLhsHead x = x
deQualName :: Name -> Name
deQualName = mkName . nameBase
------------------------------
instance Ppr FunDep where
ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs))
------------------------------
instance Ppr Foreign where
ppr (ImportF callconv safety impent as typ)
= text "foreign import"
<+> showtextl callconv
<+> showtextl safety
<+> text (show impent)
<+> ppr as
<+> text "::" <+> ppr typ
ppr (ExportF callconv expent as typ)
= text "foreign export"
<+> showtextl callconv
<+> text (show expent)
<+> ppr as
<+> text "::" <+> ppr typ
------------------------------
instance Ppr Clause where
ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs
$$ where_clause ds
------------------------------
instance Ppr Con where
ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts)
ppr (RecC c vsts)
= ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts))
ppr (InfixC st1 c st2) = pprStrictType st1 <+> pprName_ False c <+> pprStrictType st2
ppr (ForallC ns ctxt con) = text "forall" <+> hsep (map ppr ns)
<+> char '.' <+> pprCxt ctxt <+> ppr con
------------------------------
pprVarStrictType :: (Name, Strict, Type) -> Doc
-- Slight infelicity: with print non-atomic type with parens
pprVarStrictType (v, str, t) = ppr v <+> text "::" <+> pprStrictType (str, t)
------------------------------
pprStrictType :: (Strict, Type) -> Doc
-- Prints with parens if not already atomic
pprStrictType (IsStrict, t) = char '!' <> pprParendType t
pprStrictType (NotStrict, t) = pprParendType t
------------------------------
pprParendType :: Type -> Doc
pprParendType (VarT v) = ppr v
pprParendType (ConT c)
| c == ''[] = pprParendType ListT
| c == ''(->) = pprParendType ArrowT
| isTupleT (ConT c) = pprParendType (TupleT (length (nameBase c) - 1))
| otherwise = ppr c
pprParendType (TupleT 0) = text "()"
pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))
pprParendType ArrowT = parens (text "->")
pprParendType ListT = text "[]"
pprParendType other = parens (ppr other)
instance Ppr Type where
ppr (ForallT tvars ctxt ty) =
text "forall" <+> hsep (map ppr tvars) <+> text "."
<+> pprCxt ctxt <+> ppr ty
#if __GLASGOW_HASKELL__ >= 706
ppr StarT = text "*"
#endif
ppr ty = pprTyApp (split ty)
pprTyApp :: (Type, [Type]) -> Doc
pprTyApp (ArrowT, [arg1,arg2]) = sep [ppr arg1 <+> text "->", ppr arg2]
pprTyApp (ListT, [arg]) = brackets (ppr arg)
pprTyApp (TupleT n, args)
| length args == n = parens (sep (punctuate comma (map ppr args)))
pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)
split :: Type -> (Type, [Type]) -- Split into function and args
split t = go t []
where go (AppT t1 t2) args = go t1 (t2:args)
go ty args = (ty, args)
------------------------------
pprCxt :: Cxt -> Doc
pprCxt [] = empty
pprCxt [t] = ppr t <+> text "=>"
pprCxt ts = parens (hsep $ punctuate comma $ map ppr ts) <+> text "=>"
------------------------------
instance Ppr Range where
ppr = brackets . pprRange
where pprRange :: Range -> Doc
pprRange (FromR e) = ppr e <> text ".."
pprRange (FromThenR e1 e2) = ppr e1 <> text ","
<> ppr e2 <> text ".."
pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2
pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","
<> ppr e2 <> text ".."
<> ppr e3
------------------------------
where_clause :: [Dec] -> Doc
where_clause [] = empty
where_clause ds = nest nestDepth $ text "where" <+> vcat (map ppr ds)
showtextl :: Show a => a -> Doc
showtextl = text . map toLower . show
#if __GLASGOW_HASKELL__ >= 612
instance Ppr TyVarBndr where
ppr (PlainTV v) = ppr v
ppr (KindedTV v k) = parens $ ppr v <+> text "::" <+> ppr k
#if __GLASGOW_HASKELL__ < 706
instance Ppr Kind where
ppr StarK = text "*"
ppr (ArrowK j k) = ppr j <+> text "->" <+> ppr k
#endif
#if __GLASGOW_HASKELL__ < 709
instance Ppr Pred where
ppr (ClassP n ts) = ppr n <+> hsep (map ppr ts)
ppr (EqualP t u ) = ppr t <+> text "~" <+> ppr u
#endif
#endif
|
