never executed always true always false
1 {-# LANGUAGE OverloadedStrings #-}
2
3 -- |
4 --
5 -- Module : Aihc.Parser.Shorthand
6 -- Description : Compact pretty-printing for debugging/inspection
7 --
8 -- This module provides a compact, human-readable representation of parsed
9 -- AST structures via the 'Shorthand' typeclass. Key features:
10 --
11 -- * Source spans are omitted to reduce noise
12 -- * Empty fields (Nothing, [], False, etc.) are omitted
13 -- * Output is on a single line by default
14 -- * Uses the prettyprinter library for consistent formatting
15 --
16 -- Example:
17 --
18 -- >>> shorthand $ parseModule defaultConfig "module Demo where x = 1"
19 -- ParseOk (Module {name = "Demo", decls = [DeclValue (FunctionBind "x" [Match {rhs = UnguardedRhs (EInt 1)}])]})
20 module Aihc.Parser.Shorthand
21 ( Shorthand (..),
22 )
23 where
24
25 import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..))
26 import Aihc.Parser.Syntax
27 import Aihc.Parser.Types (ParseResult (..))
28 import Data.Text (Text)
29 import Prettyprinter
30 ( Doc,
31 Pretty (..),
32 braces,
33 brackets,
34 comma,
35 dquotes,
36 hsep,
37 parens,
38 punctuate,
39 (<+>),
40 )
41
42 -- $setup
43 -- >>> :set -XOverloadedStrings
44 -- >>> import Aihc.Parser
45
46 -- | Typeclass for compact, human-readable AST representations.
47 --
48 -- The 'shorthand' method produces a 'Doc' that can be rendered to text
49 -- or shown as a string. This is useful for debugging and golden tests.
50 --
51 -- Use 'show' on the result of 'shorthand' to get a 'String':
52 --
53 -- @
54 -- show (shorthand expr) :: String
55 -- @
56 class Shorthand a where
57 shorthand :: a -> Doc ()
58
59 -- ParseResult
60
61 instance (Shorthand a) => Shorthand (ParseResult a) where
62 shorthand (ParseOk a) = "ParseOk" <+> parens (shorthand a)
63 shorthand (ParseErr _) = "ParseErr"
64
65 -- Module
66
67 instance Shorthand Module where
68 shorthand modu =
69 "Module" <+> braces (hsep (punctuate comma fields))
70 where
71 fields =
72 optionalField "name" docText (moduleName modu)
73 <> listField "languagePragmas" docExtensionSetting (moduleLanguagePragmas modu)
74 <> optionalField "warningText" docWarningText (moduleWarningText modu)
75 <> optionalField "exports" (brackets . hsep . punctuate comma . map docExportSpec) (moduleExports modu)
76 <> listField "imports" docImportDecl (moduleImports modu)
77 <> listField "decls" docDecl (moduleDecls modu)
78
79 instance Shorthand Expr where
80 shorthand = docExpr
81
82 instance Shorthand Pattern where
83 shorthand = docPattern
84
85 instance Shorthand Type where
86 shorthand = docType
87
88 instance Shorthand LexToken where
89 shorthand = docToken
90
91 instance Shorthand LexTokenKind where
92 shorthand = docTokenKind
93
94 docWarningText :: WarningText -> Doc ann
95 docWarningText wt =
96 case wt of
97 DeprText _ msg -> "DeprText" <+> docText msg
98 WarnText _ msg -> "WarnText" <+> docText msg
99
100 docExtensionSetting :: ExtensionSetting -> Doc ann
101 docExtensionSetting setting =
102 case setting of
103 EnableExtension ext -> "EnableExtension" <+> pretty (extensionName ext)
104 DisableExtension ext -> "DisableExtension" <+> pretty (extensionName ext)
105
106 docExportSpec :: ExportSpec -> Doc ann
107 docExportSpec spec =
108 case spec of
109 ExportModule _ name -> "ExportModule" <+> docText name
110 ExportVar _ mNamespace name ->
111 "ExportVar" <> braces (hsep (punctuate comma (optionalField "namespace" docText mNamespace <> [field "name" (docText name)])))
112 ExportAbs _ mNamespace name ->
113 "ExportAbs" <> braces (hsep (punctuate comma (optionalField "namespace" docText mNamespace <> [field "name" (docText name)])))
114 ExportAll _ mNamespace name ->
115 "ExportAll" <> braces (hsep (punctuate comma (optionalField "namespace" docText mNamespace <> [field "name" (docText name)])))
116 ExportWith _ mNamespace name members ->
117 "ExportWith" <> braces (hsep (punctuate comma (optionalField "namespace" docText mNamespace <> [field "name" (docText name), field "members" (docTextList members)])))
118
119 docImportDecl :: ImportDecl -> Doc ann
120 docImportDecl decl =
121 "ImportDecl" <+> braces (hsep (punctuate comma fields))
122 where
123 fields =
124 [field "module" (docText (importDeclModule decl))]
125 <> boolField "qualified" (importDeclQualified decl)
126 <> boolField "qualifiedPost" (importDeclQualifiedPost decl)
127 <> optionalField "level" docImportLevel (importDeclLevel decl)
128 <> optionalField "package" docText (importDeclPackage decl)
129 <> optionalField "as" docText (importDeclAs decl)
130 <> optionalField "spec" docImportSpec (importDeclSpec decl)
131
132 docImportLevel :: ImportLevel -> Doc ann
133 docImportLevel level =
134 case level of
135 ImportLevelQuote -> "ImportLevelQuote"
136 ImportLevelSplice -> "ImportLevelSplice"
137
138 docImportSpec :: ImportSpec -> Doc ann
139 docImportSpec spec =
140 "ImportSpec" <+> braces (hsep (punctuate comma fields))
141 where
142 fields =
143 boolField "hiding" (importSpecHiding spec)
144 <> [field "items" (brackets (hsep (punctuate comma (map docImportItem (importSpecItems spec)))))]
145
146 docImportItem :: ImportItem -> Doc ann
147 docImportItem item =
148 case item of
149 ImportItemVar _ mNamespace name ->
150 "ImportItemVar" <> braces (hsep (punctuate comma (optionalField "namespace" docText mNamespace <> [field "name" (docText name)])))
151 ImportItemAbs _ mNamespace name ->
152 "ImportItemAbs" <> braces (hsep (punctuate comma (optionalField "namespace" docText mNamespace <> [field "name" (docText name)])))
153 ImportItemAll _ mNamespace name ->
154 "ImportItemAll" <> braces (hsep (punctuate comma (optionalField "namespace" docText mNamespace <> [field "name" (docText name)])))
155 ImportItemWith _ mNamespace name members ->
156 "ImportItemWith" <> braces (hsep (punctuate comma (optionalField "namespace" docText mNamespace <> [field "name" (docText name), field "members" (docTextList members)])))
157
158 -- Declarations
159
160 docDecl :: Decl -> Doc ann
161 docDecl decl =
162 case decl of
163 DeclValue _ vdecl -> "DeclValue" <+> parens (docValueDecl vdecl)
164 DeclTypeSig _ names ty -> "DeclTypeSig" <+> braces (hsep (punctuate comma [field "names" (docTextList names), field "type" (docType ty)]))
165 DeclStandaloneKindSig _ name kind -> "DeclStandaloneKindSig" <+> braces (hsep (punctuate comma [field "name" (docText name), field "kind" (docType kind)]))
166 DeclFixity _ assoc mPrec ops -> "DeclFixity" <+> braces (hsep (punctuate comma ([field "assoc" (docFixityAssoc assoc)] <> optionalField "prec" pretty mPrec <> [field "ops" (docTextList ops)])))
167 DeclTypeSyn _ syn -> "DeclTypeSyn" <+> parens (docTypeSynDecl syn)
168 DeclData _ dd -> "DeclData" <+> parens (docDataDecl dd)
169 DeclNewtype _ nd -> "DeclNewtype" <+> parens (docNewtypeDecl nd)
170 DeclClass _ cd -> "DeclClass" <+> parens (docClassDecl cd)
171 DeclInstance _ inst -> "DeclInstance" <+> parens (docInstanceDecl inst)
172 DeclStandaloneDeriving _ sd -> "DeclStandaloneDeriving" <+> parens (docStandaloneDerivingDecl sd)
173 DeclDefault _ tys -> "DeclDefault" <+> brackets (hsep (punctuate comma (map docType tys)))
174 DeclForeign _ fd -> "DeclForeign" <+> parens (docForeignDecl fd)
175
176 docValueDecl :: ValueDecl -> Doc ann
177 docValueDecl vdecl =
178 case vdecl of
179 FunctionBind _ name matches -> "FunctionBind" <+> docText name <+> brackets (hsep (punctuate comma (map docMatch matches)))
180 PatternBind _ pat rhs -> "PatternBind" <+> docPattern pat <+> docRhs rhs
181
182 docMatch :: Match -> Doc ann
183 docMatch m =
184 "Match" <+> braces (hsep (punctuate comma fields))
185 where
186 fields =
187 listField "pats" docPattern (matchPats m)
188 <> [field "rhs" (docRhs (matchRhs m))]
189
190 docRhs :: Rhs -> Doc ann
191 docRhs rhs =
192 case rhs of
193 UnguardedRhs _ expr -> "UnguardedRhs" <+> parens (docExpr expr)
194 GuardedRhss _ grhss -> "GuardedRhss" <+> brackets (hsep (punctuate comma (map docGuardedRhs grhss)))
195
196 docGuardedRhs :: GuardedRhs -> Doc ann
197 docGuardedRhs grhs =
198 "GuardedRhs" <+> braces (hsep (punctuate comma [field "guards" (brackets (hsep (punctuate comma (map docGuardQualifier (guardedRhsGuards grhs))))), field "body" (docExpr (guardedRhsBody grhs))]))
199
200 docGuardQualifier :: GuardQualifier -> Doc ann
201 docGuardQualifier gq =
202 case gq of
203 GuardExpr _ expr -> "GuardExpr" <+> parens (docExpr expr)
204 GuardPat _ pat expr -> "GuardPat" <+> parens (docPattern pat) <+> parens (docExpr expr)
205 GuardLet _ decls -> "GuardLet" <+> brackets (hsep (punctuate comma (map docDecl decls)))
206
207 docTypeSynDecl :: TypeSynDecl -> Doc ann
208 docTypeSynDecl syn =
209 "TypeSynDecl" <+> braces (hsep (punctuate comma fields))
210 where
211 fields =
212 [field "name" (docText (typeSynName syn))]
213 <> listField "params" docTyVarBinder (typeSynParams syn)
214 <> [field "body" (docType (typeSynBody syn))]
215
216 docDataDecl :: DataDecl -> Doc ann
217 docDataDecl dd =
218 "DataDecl" <+> braces (hsep (punctuate comma fields))
219 where
220 fields =
221 [field "name" (docText (dataDeclName dd))]
222 <> listField "context" docConstraint (dataDeclContext dd)
223 <> listField "params" docTyVarBinder (dataDeclParams dd)
224 <> listField "constructors" docDataConDecl (dataDeclConstructors dd)
225 <> listField "deriving" docDerivingClause (dataDeclDeriving dd)
226
227 docNewtypeDecl :: NewtypeDecl -> Doc ann
228 docNewtypeDecl nd =
229 "NewtypeDecl" <+> braces (hsep (punctuate comma fields))
230 where
231 fields =
232 [field "name" (docText (newtypeDeclName nd))]
233 <> listField "context" docConstraint (newtypeDeclContext nd)
234 <> listField "params" docTyVarBinder (newtypeDeclParams nd)
235 <> optionalField "constructor" docDataConDecl (newtypeDeclConstructor nd)
236 <> listField "deriving" docDerivingClause (newtypeDeclDeriving nd)
237
238 docDataConDecl :: DataConDecl -> Doc ann
239 docDataConDecl dcd =
240 case dcd of
241 PrefixCon _ forallVars constraints name fields' ->
242 "PrefixCon" <+> braces (hsep (punctuate comma ([field "name" (docText name)] <> listField "forallVars" docText forallVars <> listField "constraints" docConstraint constraints <> listField "fields" docBangType fields')))
243 InfixCon _ forallVars constraints lhs op rhs ->
244 "InfixCon" <+> braces (hsep (punctuate comma ([field "op" (docText op), field "lhs" (docBangType lhs), field "rhs" (docBangType rhs)] <> listField "forallVars" docText forallVars <> listField "constraints" docConstraint constraints)))
245 RecordCon _ forallVars constraints name fields' ->
246 "RecordCon" <+> braces (hsep (punctuate comma ([field "name" (docText name)] <> listField "forallVars" docText forallVars <> listField "constraints" docConstraint constraints <> listField "fields" docFieldDecl fields')))
247 GadtCon _ forallBinders constraints names body ->
248 "GadtCon" <+> braces (hsep (punctuate comma (listField "names" docText names <> listField "forallBinders" docTyVarBinder forallBinders <> listField "constraints" docConstraint constraints <> [field "body" (docGadtBody body)])))
249
250 -- | Document a GADT body
251 docGadtBody :: GadtBody -> Doc ann
252 docGadtBody body =
253 case body of
254 GadtPrefixBody args resultTy ->
255 "GadtPrefixBody" <+> braces (hsep (punctuate comma (listField "args" docBangType args <> [field "result" (docType resultTy)])))
256 GadtRecordBody fields' resultTy ->
257 "GadtRecordBody" <+> braces (hsep (punctuate comma (listField "fields" docFieldDecl fields' <> [field "result" (docType resultTy)])))
258
259 docBangType :: BangType -> Doc ann
260 docBangType bt =
261 "BangType" <+> braces (hsep (punctuate comma fields))
262 where
263 fields =
264 boolField "strict" (bangStrict bt)
265 <> [field "type" (docType (bangType bt))]
266
267 docFieldDecl :: FieldDecl -> Doc ann
268 docFieldDecl fd =
269 "FieldDecl" <+> braces (hsep (punctuate comma [field "names" (docTextList (fieldNames fd)), field "type" (docBangType (fieldType fd))]))
270
271 docDerivingClause :: DerivingClause -> Doc ann
272 docDerivingClause dc =
273 "DerivingClause" <+> braces (hsep (punctuate comma fields))
274 where
275 fields =
276 optionalField "strategy" docDerivingStrategy (derivingStrategy dc)
277 <> listField "classes" docText (derivingClasses dc)
278
279 docDerivingStrategy :: DerivingStrategy -> Doc ann
280 docDerivingStrategy ds =
281 case ds of
282 DerivingStock -> "DerivingStock"
283 DerivingNewtype -> "DerivingNewtype"
284 DerivingAnyclass -> "DerivingAnyclass"
285
286 docClassDecl :: ClassDecl -> Doc ann
287 docClassDecl cd =
288 "ClassDecl" <+> braces (hsep (punctuate comma fields))
289 where
290 fields =
291 [field "name" (docText (classDeclName cd))]
292 <> optionalField "context" (brackets . hsep . punctuate comma . map docConstraint) (classDeclContext cd)
293 <> listField "params" docTyVarBinder (classDeclParams cd)
294 <> listField "items" docClassDeclItem (classDeclItems cd)
295
296 docClassDeclItem :: ClassDeclItem -> Doc ann
297 docClassDeclItem item =
298 case item of
299 ClassItemTypeSig _ names ty -> "ClassItemTypeSig" <+> braces (hsep (punctuate comma [field "names" (docTextList names), field "type" (docType ty)]))
300 ClassItemFixity _ assoc mPrec ops -> "ClassItemFixity" <+> braces (hsep (punctuate comma ([field "assoc" (docFixityAssoc assoc)] <> optionalField "prec" pretty mPrec <> [field "ops" (docTextList ops)])))
301 ClassItemDefault _ vdecl -> "ClassItemDefault" <+> parens (docValueDecl vdecl)
302
303 docInstanceDecl :: InstanceDecl -> Doc ann
304 docInstanceDecl inst =
305 "InstanceDecl" <+> braces (hsep (punctuate comma fields))
306 where
307 fields =
308 [field "className" (docText (instanceDeclClassName inst))]
309 <> listField "context" docConstraint (instanceDeclContext inst)
310 <> [field "types" (brackets (hsep (punctuate comma (map docType (instanceDeclTypes inst)))))]
311 <> listField "items" docInstanceDeclItem (instanceDeclItems inst)
312
313 docInstanceDeclItem :: InstanceDeclItem -> Doc ann
314 docInstanceDeclItem item =
315 case item of
316 InstanceItemBind _ vdecl -> "InstanceItemBind" <+> parens (docValueDecl vdecl)
317 InstanceItemTypeSig _ names ty -> "InstanceItemTypeSig" <+> braces (hsep (punctuate comma [field "names" (docTextList names), field "type" (docType ty)]))
318 InstanceItemFixity _ assoc mPrec ops -> "InstanceItemFixity" <+> braces (hsep (punctuate comma ([field "assoc" (docFixityAssoc assoc)] <> optionalField "prec" pretty mPrec <> [field "ops" (docTextList ops)])))
319
320 docStandaloneDerivingDecl :: StandaloneDerivingDecl -> Doc ann
321 docStandaloneDerivingDecl sd =
322 "StandaloneDerivingDecl" <+> braces (hsep (punctuate comma fields))
323 where
324 fields =
325 [field "className" (docText (standaloneDerivingClassName sd))]
326 <> optionalField "strategy" docDerivingStrategy (standaloneDerivingStrategy sd)
327 <> listField "context" docConstraint (standaloneDerivingContext sd)
328 <> [field "types" (brackets (hsep (punctuate comma (map docType (standaloneDerivingTypes sd)))))]
329
330 docForeignDecl :: ForeignDecl -> Doc ann
331 docForeignDecl fd =
332 "ForeignDecl" <+> braces (hsep (punctuate comma fields))
333 where
334 fields =
335 [field "direction" (docForeignDirection (foreignDirection fd))]
336 <> [field "callConv" (docCallConv (foreignCallConv fd))]
337 <> optionalField "safety" docForeignSafety (foreignSafety fd)
338 <> [field "entity" (docForeignEntitySpec (foreignEntity fd))]
339 <> [field "name" (docText (foreignName fd))]
340 <> [field "type" (docType (foreignType fd))]
341
342 docForeignDirection :: ForeignDirection -> Doc ann
343 docForeignDirection fd =
344 case fd of
345 ForeignImport -> "ForeignImport"
346 ForeignExport -> "ForeignExport"
347
348 docCallConv :: CallConv -> Doc ann
349 docCallConv cc =
350 case cc of
351 CCall -> "CCall"
352 StdCall -> "StdCall"
353
354 docForeignSafety :: ForeignSafety -> Doc ann
355 docForeignSafety fs =
356 case fs of
357 Safe -> "Safe"
358 Unsafe -> "Unsafe"
359
360 docForeignEntitySpec :: ForeignEntitySpec -> Doc ann
361 docForeignEntitySpec spec =
362 case spec of
363 ForeignEntityDynamic -> "ForeignEntityDynamic"
364 ForeignEntityWrapper -> "ForeignEntityWrapper"
365 ForeignEntityStatic mName -> "ForeignEntityStatic" <> optionalField' docText mName
366 ForeignEntityAddress mName -> "ForeignEntityAddress" <> optionalField' docText mName
367 ForeignEntityNamed name -> "ForeignEntityNamed" <+> docText name
368 ForeignEntityOmitted -> "ForeignEntityOmitted"
369
370 docFixityAssoc :: FixityAssoc -> Doc ann
371 docFixityAssoc fa =
372 case fa of
373 Infix -> "Infix"
374 InfixL -> "InfixL"
375 InfixR -> "InfixR"
376
377 -- Types
378
379 docType :: Type -> Doc ann
380 docType ty =
381 case ty of
382 TVar _ name -> "TVar" <+> docText name
383 TCon _ name promoted ->
384 if promoted == Promoted
385 then "TConPromoted" <+> docText name
386 else "TCon" <+> docText name
387 TTypeLit _ lit -> "TTypeLit" <+> docTypeLiteral lit
388 TStar _ -> "TStar"
389 TQuasiQuote _ quoter body -> "TQuasiQuote" <+> docText quoter <+> docText body
390 TForall _ binders inner -> "TForall" <+> brackets (hsep (punctuate comma (map docText binders))) <+> parens (docType inner)
391 TApp _ f x -> "TApp" <+> parens (docType f) <+> parens (docType x)
392 TFun _ a b -> "TFun" <+> parens (docType a) <+> parens (docType b)
393 TTuple _ promoted elems ->
394 (if promoted == Promoted then "TTuplePromoted" else "TTuple")
395 <+> brackets (hsep (punctuate comma (map docType elems)))
396 TList _ promoted inner ->
397 (if promoted == Promoted then "TListPromoted" else "TList")
398 <+> parens (docType inner)
399 TParen _ inner -> "TParen" <+> parens (docType inner)
400 TContext _ constraints inner -> "TContext" <+> brackets (hsep (punctuate comma (map docConstraint constraints))) <+> parens (docType inner)
401
402 docTypeLiteral :: TypeLiteral -> Doc ann
403 docTypeLiteral lit =
404 case lit of
405 TypeLitInteger n _ -> "TypeLitInteger" <+> pretty n
406 TypeLitSymbol s _ -> "TypeLitSymbol" <+> docText s
407 TypeLitChar c _ -> "TypeLitChar" <+> pretty (show c)
408
409 docConstraint :: Constraint -> Doc ann
410 docConstraint c =
411 "Constraint" <+> braces (hsep (punctuate comma fields))
412 where
413 fields =
414 [field "class" (docText (constraintClass c))]
415 <> listField "args" docType (constraintArgs c)
416 <> boolField "paren" (constraintParen c)
417
418 docTyVarBinder :: TyVarBinder -> Doc ann
419 docTyVarBinder tvb =
420 "TyVarBinder" <+> braces (hsep (punctuate comma fields))
421 where
422 fields =
423 [field "name" (docText (tyVarBinderName tvb))]
424 <> optionalField "kind" docType (tyVarBinderKind tvb)
425
426 -- Patterns
427
428 docPattern :: Pattern -> Doc ann
429 docPattern pat =
430 case pat of
431 PVar _ name -> "PVar" <+> docText name
432 PWildcard _ -> "PWildcard"
433 PLit _ lit -> "PLit" <+> parens (docLiteral lit)
434 PQuasiQuote _ quoter body -> "PQuasiQuote" <+> docText quoter <+> docText body
435 PTuple _ elems -> "PTuple" <+> brackets (hsep (punctuate comma (map docPattern elems)))
436 PList _ elems -> "PList" <+> brackets (hsep (punctuate comma (map docPattern elems)))
437 PCon _ name args -> "PCon" <+> docText name <+> brackets (hsep (punctuate comma (map docPattern args)))
438 PInfix _ lhs op rhs -> "PInfix" <+> parens (docPattern lhs) <+> docText op <+> parens (docPattern rhs)
439 PView _ expr inner -> "PView" <+> parens (docExpr expr) <+> parens (docPattern inner)
440 PAs _ name inner -> "PAs" <+> docText name <+> parens (docPattern inner)
441 PStrict _ inner -> "PStrict" <+> parens (docPattern inner)
442 PIrrefutable _ inner -> "PIrrefutable" <+> parens (docPattern inner)
443 PNegLit _ lit -> "PNegLit" <+> parens (docLiteral lit)
444 PParen _ inner -> "PParen" <+> parens (docPattern inner)
445 PRecord _ name fields' -> "PRecord" <+> docText name <+> braces (hsep (punctuate comma [docText fn <+> "=" <+> docPattern fp | (fn, fp) <- fields']))
446
447 docLiteral :: Literal -> Doc ann
448 docLiteral lit =
449 case lit of
450 LitInt _ n _ -> "LitInt" <+> pretty n
451 LitIntBase _ n repr -> "LitIntBase" <+> pretty n <+> docText repr
452 LitFloat _ n _ -> "LitFloat" <+> pretty n
453 LitChar _ c _ -> "LitChar" <+> pretty (show c)
454 LitString _ s _ -> "LitString" <+> docText s
455
456 -- Expressions
457
458 docExpr :: Expr -> Doc ann
459 docExpr expr =
460 case expr of
461 EVar _ name -> "EVar" <+> docText name
462 EInt _ n _ -> "EInt" <+> pretty n
463 EIntBase _ n repr -> "EIntBase" <+> pretty n <+> docText repr
464 EFloat _ n _ -> "EFloat" <+> pretty n
465 EChar _ c _ -> "EChar" <+> pretty (show c)
466 EString _ s _ -> "EString" <+> docText s
467 EQuasiQuote _ quoter body -> "EQuasiQuote" <+> docText quoter <+> docText body
468 EIf _ cond yes no -> "EIf" <+> parens (docExpr cond) <+> parens (docExpr yes) <+> parens (docExpr no)
469 ELambdaPats _ pats body -> "ELambdaPats" <+> brackets (hsep (punctuate comma (map docPattern pats))) <+> parens (docExpr body)
470 ELambdaCase _ alts -> "ELambdaCase" <+> brackets (hsep (punctuate comma (map docCaseAlt alts)))
471 EInfix _ lhs op rhs -> "EInfix" <+> parens (docExpr lhs) <+> docText op <+> parens (docExpr rhs)
472 ENegate _ inner -> "ENegate" <+> parens (docExpr inner)
473 ESectionL _ lhs op -> "ESectionL" <+> parens (docExpr lhs) <+> docText op
474 ESectionR _ op rhs -> "ESectionR" <+> docText op <+> parens (docExpr rhs)
475 ELetDecls _ decls body -> "ELetDecls" <+> brackets (hsep (punctuate comma (map docDecl decls))) <+> parens (docExpr body)
476 ECase _ scrutinee alts -> "ECase" <+> parens (docExpr scrutinee) <+> brackets (hsep (punctuate comma (map docCaseAlt alts)))
477 EDo _ stmts -> "EDo" <+> brackets (hsep (punctuate comma (map docDoStmt stmts)))
478 EListComp _ body quals -> "EListComp" <+> parens (docExpr body) <+> brackets (hsep (punctuate comma (map docCompStmt quals)))
479 EListCompParallel _ body qualGroups -> "EListCompParallel" <+> parens (docExpr body) <+> brackets (hsep (punctuate "|" [brackets (hsep (punctuate comma (map docCompStmt qs))) | qs <- qualGroups]))
480 EArithSeq _ seqInfo -> "EArithSeq" <+> parens (docArithSeq seqInfo)
481 ERecordCon _ name fields' -> "ERecordCon" <+> docText name <+> braces (hsep (punctuate comma [docText fn <+> "=" <+> docExpr fv | (fn, fv) <- fields']))
482 ERecordUpd _ base fields' -> "ERecordUpd" <+> parens (docExpr base) <+> braces (hsep (punctuate comma [docText fn <+> "=" <+> docExpr fv | (fn, fv) <- fields']))
483 ETypeSig _ inner ty -> "ETypeSig" <+> parens (docExpr inner) <+> parens (docType ty)
484 EParen _ inner -> "EParen" <+> parens (docExpr inner)
485 EWhereDecls _ body decls -> "EWhereDecls" <+> parens (docExpr body) <+> brackets (hsep (punctuate comma (map docDecl decls)))
486 EList _ elems -> "EList" <+> brackets (hsep (punctuate comma (map docExpr elems)))
487 ETuple _ elems -> "ETuple" <+> brackets (hsep (punctuate comma (map docExpr elems)))
488 ETupleSection _ elems -> "ETupleSection" <+> brackets (hsep (punctuate comma (map (maybe "_" docExpr) elems)))
489 ETupleCon _ arity -> "ETupleCon" <+> pretty arity
490 ETypeApp _ inner ty -> "ETypeApp" <+> parens (docExpr inner) <+> parens (docType ty)
491 EApp _ f x -> "EApp" <+> parens (docExpr f) <+> parens (docExpr x)
492
493 docCaseAlt :: CaseAlt -> Doc ann
494 docCaseAlt (CaseAlt _ pat rhs) =
495 "CaseAlt" <+> parens (docPattern pat) <+> parens (docRhs rhs)
496
497 docDoStmt :: DoStmt -> Doc ann
498 docDoStmt stmt =
499 case stmt of
500 DoBind _ pat expr -> "DoBind" <+> parens (docPattern pat) <+> parens (docExpr expr)
501 DoLet _ bindings -> "DoLet" <+> braces (hsep (punctuate comma [docText name <+> "=" <+> docExpr e | (name, e) <- bindings]))
502 DoLetDecls _ decls -> "DoLetDecls" <+> brackets (hsep (punctuate comma (map docDecl decls)))
503 DoExpr _ expr -> "DoExpr" <+> parens (docExpr expr)
504
505 docCompStmt :: CompStmt -> Doc ann
506 docCompStmt stmt =
507 case stmt of
508 CompGen _ pat expr -> "CompGen" <+> parens (docPattern pat) <+> parens (docExpr expr)
509 CompGuard _ expr -> "CompGuard" <+> parens (docExpr expr)
510 CompLet _ bindings -> "CompLet" <+> braces (hsep (punctuate comma [docText name <+> "=" <+> docExpr e | (name, e) <- bindings]))
511 CompLetDecls _ decls -> "CompLetDecls" <+> brackets (hsep (punctuate comma (map docDecl decls)))
512
513 docArithSeq :: ArithSeq -> Doc ann
514 docArithSeq seqInfo =
515 case seqInfo of
516 ArithSeqFrom _ from -> "ArithSeqFrom" <+> parens (docExpr from)
517 ArithSeqFromThen _ from thn -> "ArithSeqFromThen" <+> parens (docExpr from) <+> parens (docExpr thn)
518 ArithSeqFromTo _ from to -> "ArithSeqFromTo" <+> parens (docExpr from) <+> parens (docExpr to)
519 ArithSeqFromThenTo _ from thn to -> "ArithSeqFromThenTo" <+> parens (docExpr from) <+> parens (docExpr thn) <+> parens (docExpr to)
520
521 -- Token pretty printing
522
523 docToken :: LexToken -> Doc ann
524 docToken tok = docTokenKind (lexTokenKind tok)
525
526 docTokenKind :: LexTokenKind -> Doc ann
527 docTokenKind kind =
528 case kind of
529 TkKeywordCase -> "TkKeywordCase"
530 TkKeywordClass -> "TkKeywordClass"
531 TkKeywordData -> "TkKeywordData"
532 TkKeywordDefault -> "TkKeywordDefault"
533 TkKeywordDeriving -> "TkKeywordDeriving"
534 TkKeywordDo -> "TkKeywordDo"
535 TkKeywordElse -> "TkKeywordElse"
536 TkKeywordForeign -> "TkKeywordForeign"
537 TkKeywordIf -> "TkKeywordIf"
538 TkKeywordImport -> "TkKeywordImport"
539 TkKeywordIn -> "TkKeywordIn"
540 TkKeywordInfix -> "TkKeywordInfix"
541 TkKeywordInfixl -> "TkKeywordInfixl"
542 TkKeywordInfixr -> "TkKeywordInfixr"
543 TkKeywordInstance -> "TkKeywordInstance"
544 TkKeywordLet -> "TkKeywordLet"
545 TkKeywordModule -> "TkKeywordModule"
546 TkKeywordNewtype -> "TkKeywordNewtype"
547 TkKeywordOf -> "TkKeywordOf"
548 TkKeywordThen -> "TkKeywordThen"
549 TkKeywordType -> "TkKeywordType"
550 TkKeywordWhere -> "TkKeywordWhere"
551 TkKeywordUnderscore -> "TkKeywordUnderscore"
552 TkKeywordQualified -> "TkKeywordQualified"
553 TkKeywordAs -> "TkKeywordAs"
554 TkKeywordHiding -> "TkKeywordHiding"
555 TkReservedDotDot -> "TkReservedDotDot"
556 TkReservedColon -> "TkReservedColon"
557 TkReservedDoubleColon -> "TkReservedDoubleColon"
558 TkReservedEquals -> "TkReservedEquals"
559 TkReservedBackslash -> "TkReservedBackslash"
560 TkReservedPipe -> "TkReservedPipe"
561 TkReservedLeftArrow -> "TkReservedLeftArrow"
562 TkReservedRightArrow -> "TkReservedRightArrow"
563 TkReservedAt -> "TkReservedAt"
564 TkReservedDoubleArrow -> "TkReservedDoubleArrow"
565 TkVarId name -> "TkVarId" <+> docText name
566 TkConId name -> "TkConId" <+> docText name
567 TkQVarId name -> "TkQVarId" <+> docText name
568 TkQConId name -> "TkQConId" <+> docText name
569 TkVarSym name -> "TkVarSym" <+> docText name
570 TkConSym name -> "TkConSym" <+> docText name
571 TkQVarSym name -> "TkQVarSym" <+> docText name
572 TkQConSym name -> "TkQConSym" <+> docText name
573 TkInteger n -> "TkInteger" <+> pretty n
574 TkIntegerBase n repr -> "TkIntegerBase" <+> pretty n <+> docText repr
575 TkFloat n repr -> "TkFloat" <+> pretty n <+> docText repr
576 TkChar c -> "TkChar" <+> pretty (show c)
577 TkString s -> "TkString" <+> docText s
578 TkSpecialLParen -> "TkSpecialLParen"
579 TkSpecialRParen -> "TkSpecialRParen"
580 TkSpecialComma -> "TkSpecialComma"
581 TkSpecialSemicolon -> "TkSpecialSemicolon"
582 TkSpecialLBracket -> "TkSpecialLBracket"
583 TkSpecialRBracket -> "TkSpecialRBracket"
584 TkSpecialBacktick -> "TkSpecialBacktick"
585 TkSpecialLBrace -> "TkSpecialLBrace"
586 TkSpecialRBrace -> "TkSpecialRBrace"
587 TkMinusOperator -> "TkMinusOperator"
588 TkPrefixMinus -> "TkPrefixMinus"
589 TkPrefixBang -> "TkPrefixBang"
590 TkPrefixTilde -> "TkPrefixTilde"
591 TkPragmaLanguage settings -> "TkPragmaLanguage" <+> brackets (hsep (punctuate comma (map docExtensionSetting settings)))
592 TkPragmaWarning msg -> "TkPragmaWarning" <+> docText msg
593 TkPragmaDeprecated msg -> "TkPragmaDeprecated" <+> docText msg
594 TkQuasiQuote quoter body -> "TkQuasiQuote" <+> docText quoter <+> docText body
595 TkError msg -> "TkError" <+> docText msg
596
597 -- Helpers
598
599 field :: Text -> Doc ann -> Doc ann
600 field name val = pretty name <+> "=" <+> val
601
602 optionalField :: Text -> (a -> Doc ann) -> Maybe a -> [Doc ann]
603 optionalField name f mVal =
604 case mVal of
605 Just val -> [field name (f val)]
606 Nothing -> []
607
608 optionalField' :: (a -> Doc ann) -> Maybe a -> Doc ann
609 optionalField' f mVal =
610 case mVal of
611 Just val -> " " <> f val
612 Nothing -> ""
613
614 listField :: Text -> (a -> Doc ann) -> [a] -> [Doc ann]
615 listField _ _ [] = []
616 listField name f xs = [field name (brackets (hsep (punctuate comma (map f xs))))]
617
618 boolField :: Text -> Bool -> [Doc ann]
619 boolField _ False = []
620 boolField name True = [field name "True"]
621
622 docText :: Text -> Doc ann
623 docText t = dquotes (pretty t)
624
625 docTextList :: [Text] -> Doc ann
626 docTextList ts = brackets (hsep (punctuate comma (map docText ts)))