never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE DataKinds #-}
4 {-# LANGUAGE DeriveDataTypeable #-}
5 {-# LANGUAGE ExistentialQuantification #-}
6 {-# LANGUAGE FlexibleContexts #-}
7 {-# LANGUAGE FlexibleInstances #-}
8 {-# LANGUAGE LambdaCase #-}
9 {-# LANGUAGE MultiParamTypeClasses #-}
10 {-# LANGUAGE ScopedTypeVariables #-}
11 {-# LANGUAGE StandaloneDeriving #-}
12 {-# LANGUAGE TypeApplications #-}
13 {-# LANGUAGE TypeFamilyDependencies #-}
14 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
15 -- in module Language.Haskell.Syntax.Extension
16
17 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
18 {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable
19
20 {-
21 (c) The University of Glasgow 2006
22 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
23 -}
24
25 -- | Abstract Haskell syntax for expressions.
26 module GHC.Hs.Expr
27 ( module Language.Haskell.Syntax.Expr
28 , module GHC.Hs.Expr
29 ) where
30
31 import Language.Haskell.Syntax.Expr
32
33 -- friends:
34 import GHC.Prelude
35
36 import GHC.Hs.Decls
37 import GHC.Hs.Pat
38 import GHC.Hs.Lit
39 import Language.Haskell.Syntax.Extension
40 import GHC.Hs.Extension
41 import GHC.Hs.Type
42 import GHC.Hs.Binds
43 import GHC.Parser.Annotation
44
45 -- others:
46 import GHC.Tc.Types.Evidence
47 import GHC.Core.DataCon (FieldLabelString)
48 import GHC.Types.Name
49 import GHC.Types.Name.Set
50 import GHC.Types.Basic
51 import GHC.Types.Fixity
52 import GHC.Types.SourceText
53 import GHC.Types.SrcLoc
54 import GHC.Types.Tickish (CoreTickish)
55 import GHC.Types.Var( InvisTVBinder )
56 import GHC.Core.ConLike
57 import GHC.Unit.Module (ModuleName)
58 import GHC.Utils.Misc
59 import GHC.Utils.Outputable
60 import GHC.Utils.Panic
61 import GHC.Utils.Panic.Plain
62 import GHC.Data.FastString
63 import GHC.Core.Type
64 import GHC.Builtin.Types (mkTupleStr)
65 import GHC.Tc.Utils.TcType (TcType)
66 import {-# SOURCE #-} GHC.Tc.Types (TcLclEnv)
67
68 -- libraries:
69 import Data.Data hiding (Fixity(..))
70 import qualified Data.Data as Data (Fixity(..))
71 import qualified Data.Kind
72 import Data.Maybe (isJust)
73 import Data.Void ( Void )
74
75 {- *********************************************************************
76 * *
77 Expressions proper
78 * *
79 ********************************************************************* -}
80
81 -- | Post-Type checking Expression
82 --
83 -- PostTcExpr is an evidence expression attached to the syntax tree by the
84 -- type checker (c.f. postTcType).
85 type PostTcExpr = HsExpr GhcTc
86
87 -- | Post-Type checking Table
88 --
89 -- We use a PostTcTable where there are a bunch of pieces of evidence, more
90 -- than is convenient to keep individually.
91 type PostTcTable = [(Name, PostTcExpr)]
92
93 -------------------------
94
95 -- Defining SyntaxExpr in two stages allows for better type inference, because
96 -- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity,
97 -- noSyntaxExpr would be ambiguous.
98 type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p
99
100 type family SyntaxExprGhc (p :: Pass) = (r :: Data.Kind.Type) | r -> p where
101 SyntaxExprGhc 'Parsed = NoExtField
102 SyntaxExprGhc 'Renamed = SyntaxExprRn
103 SyntaxExprGhc 'Typechecked = SyntaxExprTc
104
105 -- | The function to use in rebindable syntax. See Note [NoSyntaxExpr].
106 data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn)
107 -- Why is the payload not just a Name?
108 -- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"
109 | NoSyntaxExprRn
110
111 -- | An expression with wrappers, used for rebindable syntax
112 --
113 -- This should desugar to
114 --
115 -- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0)
116 -- > (syn_arg_wraps[1] arg1) ...
117 --
118 -- where the actual arguments come from elsewhere in the AST.
119 data SyntaxExprTc = SyntaxExprTc { syn_expr :: HsExpr GhcTc
120 , syn_arg_wraps :: [HsWrapper]
121 , syn_res_wrap :: HsWrapper }
122 | NoSyntaxExprTc -- See Note [NoSyntaxExpr]
123
124 -- | This is used for rebindable-syntax pieces that are too polymorphic
125 -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)
126 noExpr :: HsExpr (GhcPass p)
127 noExpr = HsLit noComments (HsString (SourceText "noExpr") (fsLit "noExpr"))
128
129 noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p)
130 -- Before renaming, and sometimes after
131 -- See Note [NoSyntaxExpr]
132 noSyntaxExpr = case ghcPass @p of
133 GhcPs -> noExtField
134 GhcRn -> NoSyntaxExprRn
135 GhcTc -> NoSyntaxExprTc
136
137 -- | Make a 'SyntaxExpr GhcRn' from an expression
138 -- Used only in getMonadFailOp.
139 -- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"
140 mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn
141 mkSyntaxExpr = SyntaxExprRn
142
143 -- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the
144 -- renamer).
145 mkRnSyntaxExpr :: Name -> SyntaxExprRn
146 mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLocA name
147
148 instance Outputable SyntaxExprRn where
149 ppr (SyntaxExprRn expr) = ppr expr
150 ppr NoSyntaxExprRn = text "<no syntax expr>"
151
152 instance Outputable SyntaxExprTc where
153 ppr (SyntaxExprTc { syn_expr = expr
154 , syn_arg_wraps = arg_wraps
155 , syn_res_wrap = res_wrap })
156 = sdocOption sdocPrintExplicitCoercions $ \print_co ->
157 getPprDebug $ \debug ->
158 if debug || print_co
159 then ppr expr <> braces (pprWithCommas ppr arg_wraps)
160 <> braces (ppr res_wrap)
161 else ppr expr
162
163 ppr NoSyntaxExprTc = text "<no syntax expr>"
164
165 -- | Extra data fields for a 'RecordUpd', added by the type checker
166 data RecordUpdTc = RecordUpdTc
167 { rupd_cons :: [ConLike]
168 -- Filled in by the type checker to the
169 -- _non-empty_ list of DataCons that have
170 -- all the upd'd fields
171
172 , rupd_in_tys :: [Type] -- Argument types of *input* record type
173 , rupd_out_tys :: [Type] -- and *output* record type
174 -- For a data family, these are the type args of the
175 -- /representation/ type constructor
176
177 , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper]
178 }
179
180 -- | HsWrap appears only in typechecker output
181 data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper
182 (hs_syn GhcTc) -- the thing that is wrapped
183
184 deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn)
185
186 type instance HsBracketRn (GhcPass _) = GhcRn
187 type instance PendingRnSplice' (GhcPass _) = PendingRnSplice
188 type instance PendingTcSplice' (GhcPass _) = PendingTcSplice
189
190 -- ---------------------------------------------------------------------
191
192 {- Note [Constructor cannot occur]
193 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
194 Some data constructors can't occur in certain phases; e.g. the output
195 of the type checker never has OverLabel. We signal this by
196 * setting the extension field to Void
197 * using dataConCantHappen in the cases that can't happen
198
199 For example:
200
201 type instance XOverLabel GhcTc = Void
202
203 dsExpr :: HsExpr GhcTc -> blah
204 dsExpr (HsOverLabel x _) = dataConCantHappen x
205
206 The function dataConCantHappen is defined thus:
207 dataConCantHappen :: Void -> a
208 dataConCantHappen x = case x of {}
209 (i.e. identically to Data.Void.absurd, but more helpfully named).
210 Remember Void is a type whose only element is bottom.
211
212 It would be better to omit the pattern match altogether, but we
213 could only do that if the extension field was strict (#18764).
214 -}
215
216 -- API Annotations types
217
218 data EpAnnHsCase = EpAnnHsCase
219 { hsCaseAnnCase :: EpaLocation
220 , hsCaseAnnOf :: EpaLocation
221 , hsCaseAnnsRest :: [AddEpAnn]
222 } deriving Data
223
224 data EpAnnUnboundVar = EpAnnUnboundVar
225 { hsUnboundBackquotes :: (EpaLocation, EpaLocation)
226 , hsUnboundHole :: EpaLocation
227 } deriving Data
228
229 type instance XVar (GhcPass _) = NoExtField
230
231 -- Record selectors at parse time are HsVar; they convert to HsRecSel
232 -- on renaming.
233 type instance XRecSel GhcPs = Void
234 type instance XRecSel GhcRn = NoExtField
235 type instance XRecSel GhcTc = NoExtField
236
237 type instance XLam (GhcPass _) = NoExtField
238
239 -- OverLabel not present in GhcTc pass; see GHC.Rename.Expr
240 -- Note [Handling overloaded and rebindable constructs]
241 type instance XOverLabel GhcPs = EpAnnCO
242 type instance XOverLabel GhcRn = EpAnnCO
243 type instance XOverLabel GhcTc = Void -- See Note [Constructor cannot occur]
244
245 -- ---------------------------------------------------------------------
246
247 type instance XVar (GhcPass _) = NoExtField
248
249 type instance XUnboundVar GhcPs = EpAnn EpAnnUnboundVar
250 type instance XUnboundVar GhcRn = NoExtField
251 type instance XUnboundVar GhcTc = HoleExprRef
252 -- We really don't need the whole HoleExprRef; just the IORef EvTerm
253 -- would be enough. But then deriving a Data instance becomes impossible.
254 -- Much, much easier just to define HoleExprRef with a Data instance and
255 -- store the whole structure.
256
257 type instance XIPVar GhcPs = EpAnnCO
258 type instance XIPVar GhcRn = EpAnnCO
259 type instance XIPVar GhcTc = Void -- See Note [Constructor cannot occur]
260 type instance XOverLitE (GhcPass _) = EpAnnCO
261 type instance XLitE (GhcPass _) = EpAnnCO
262
263 type instance XLam (GhcPass _) = NoExtField
264
265 type instance XLamCase (GhcPass _) = EpAnn [AddEpAnn]
266 type instance XApp (GhcPass _) = EpAnnCO
267
268 type instance XAppTypeE GhcPs = SrcSpan -- Where the `@` lives
269 type instance XAppTypeE GhcRn = NoExtField
270 type instance XAppTypeE GhcTc = Type
271
272 -- OpApp not present in GhcTc pass; see GHC.Rename.Expr
273 -- Note [Handling overloaded and rebindable constructs]
274 type instance XOpApp GhcPs = EpAnn [AddEpAnn]
275 type instance XOpApp GhcRn = Fixity
276 type instance XOpApp GhcTc = Void -- See Note [Constructor cannot occur]
277
278 -- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr
279 -- Note [Handling overloaded and rebindable constructs]
280 type instance XSectionL GhcPs = EpAnnCO
281 type instance XSectionR GhcPs = EpAnnCO
282 type instance XSectionL GhcRn = EpAnnCO
283 type instance XSectionR GhcRn = EpAnnCO
284 type instance XSectionL GhcTc = Void -- See Note [Constructor cannot occur]
285 type instance XSectionR GhcTc = Void -- See Note [Constructor cannot occur]
286
287
288 type instance XNegApp GhcPs = EpAnn [AddEpAnn]
289 type instance XNegApp GhcRn = NoExtField
290 type instance XNegApp GhcTc = NoExtField
291
292 type instance XPar (GhcPass _) = EpAnnCO
293
294 type instance XExplicitTuple GhcPs = EpAnn [AddEpAnn]
295 type instance XExplicitTuple GhcRn = NoExtField
296 type instance XExplicitTuple GhcTc = NoExtField
297
298 type instance XExplicitSum GhcPs = EpAnn AnnExplicitSum
299 type instance XExplicitSum GhcRn = NoExtField
300 type instance XExplicitSum GhcTc = [Type]
301
302 type instance XCase GhcPs = EpAnn EpAnnHsCase
303 type instance XCase GhcRn = NoExtField
304 type instance XCase GhcTc = NoExtField
305
306 type instance XIf GhcPs = EpAnn AnnsIf
307 type instance XIf GhcRn = NoExtField
308 type instance XIf GhcTc = NoExtField
309
310 type instance XMultiIf GhcPs = EpAnn [AddEpAnn]
311 type instance XMultiIf GhcRn = NoExtField
312 type instance XMultiIf GhcTc = Type
313
314 type instance XLet GhcPs = EpAnnCO
315 type instance XLet GhcRn = NoExtField
316 type instance XLet GhcTc = NoExtField
317
318 type instance XDo GhcPs = EpAnn AnnList
319 type instance XDo GhcRn = NoExtField
320 type instance XDo GhcTc = Type
321
322 type instance XExplicitList GhcPs = EpAnn AnnList
323 type instance XExplicitList GhcRn = NoExtField
324 type instance XExplicitList GhcTc = Type
325 -- GhcPs: ExplicitList includes all source-level
326 -- list literals, including overloaded ones
327 -- GhcRn and GhcTc: ExplicitList used only for list literals
328 -- that denote Haskell's built-in lists. Overloaded lists
329 -- have been expanded away in the renamer
330 -- See Note [Handling overloaded and rebindable constructs]
331 -- in GHC.Rename.Expr
332
333 type instance XRecordCon GhcPs = EpAnn [AddEpAnn]
334 type instance XRecordCon GhcRn = NoExtField
335 type instance XRecordCon GhcTc = PostTcExpr -- Instantiated constructor function
336
337 type instance XRecordUpd GhcPs = EpAnn [AddEpAnn]
338 type instance XRecordUpd GhcRn = NoExtField
339 type instance XRecordUpd GhcTc = RecordUpdTc
340
341 type instance XGetField GhcPs = EpAnnCO
342 type instance XGetField GhcRn = NoExtField
343 type instance XGetField GhcTc = Void
344 -- HsGetField is eliminated by the renamer. See [Handling overloaded
345 -- and rebindable constructs].
346
347 type instance XProjection GhcPs = EpAnn AnnProjection
348 type instance XProjection GhcRn = NoExtField
349 type instance XProjection GhcTc = Void
350 -- HsProjection is eliminated by the renamer. See [Handling overloaded
351 -- and rebindable constructs].
352
353 type instance XExprWithTySig GhcPs = EpAnn [AddEpAnn]
354 type instance XExprWithTySig GhcRn = NoExtField
355 type instance XExprWithTySig GhcTc = NoExtField
356
357 type instance XArithSeq GhcPs = EpAnn [AddEpAnn]
358 type instance XArithSeq GhcRn = NoExtField
359 type instance XArithSeq GhcTc = PostTcExpr
360
361 type instance XBracket GhcPs = EpAnn [AddEpAnn]
362 type instance XBracket GhcRn = EpAnn [AddEpAnn]
363 type instance XBracket GhcTc = Void -- See Note [Constructor cannot occur]
364
365 type instance XRnBracketOut GhcPs = Void -- See Note [Constructor cannot occur]
366 type instance XRnBracketOut GhcRn = NoExtField
367 type instance XRnBracketOut GhcTc = Void -- See Note [Constructor cannot occur]
368
369 type instance XTcBracketOut GhcPs = Void -- See Note [Constructor cannot occur]
370 type instance XTcBracketOut GhcRn = Void -- See Note [Constructor cannot occur]
371 type instance XTcBracketOut GhcTc = Type -- Type of the TcBracketOut
372
373 type instance XSpliceE (GhcPass _) = EpAnnCO
374 type instance XProc (GhcPass _) = EpAnn [AddEpAnn]
375
376 type instance XStatic GhcPs = EpAnn [AddEpAnn]
377 type instance XStatic GhcRn = NameSet
378 type instance XStatic GhcTc = NameSet
379
380 type instance XPragE (GhcPass _) = NoExtField
381
382 type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL
383 type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA
384
385 data AnnExplicitSum
386 = AnnExplicitSum {
387 aesOpen :: EpaLocation,
388 aesBarsBefore :: [EpaLocation],
389 aesBarsAfter :: [EpaLocation],
390 aesClose :: EpaLocation
391 } deriving Data
392
393 data AnnFieldLabel
394 = AnnFieldLabel {
395 afDot :: Maybe EpaLocation
396 } deriving Data
397
398 data AnnProjection
399 = AnnProjection {
400 apOpen :: EpaLocation, -- ^ '('
401 apClose :: EpaLocation -- ^ ')'
402 } deriving Data
403
404 data AnnsIf
405 = AnnsIf {
406 aiIf :: EpaLocation,
407 aiThen :: EpaLocation,
408 aiElse :: EpaLocation,
409 aiThenSemi :: Maybe EpaLocation,
410 aiElseSemi :: Maybe EpaLocation
411 } deriving Data
412
413 -- ---------------------------------------------------------------------
414
415 type instance XSCC (GhcPass _) = EpAnn AnnPragma
416 type instance XXPragE (GhcPass _) = NoExtCon
417
418 type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel
419 type instance XXDotFieldOcc (GhcPass _) = NoExtCon
420
421 type instance XPresent (GhcPass _) = EpAnn [AddEpAnn]
422
423 type instance XMissing GhcPs = EpAnn EpaLocation
424 type instance XMissing GhcRn = NoExtField
425 type instance XMissing GhcTc = Scaled Type
426
427 type instance XXTupArg (GhcPass _) = NoExtCon
428
429 tupArgPresent :: HsTupArg (GhcPass p) -> Bool
430 tupArgPresent (Present {}) = True
431 tupArgPresent (Missing {}) = False
432
433
434 {- *********************************************************************
435 * *
436 XXExpr: the extension constructor of HsExpr
437 * *
438 ********************************************************************* -}
439
440 type instance XXExpr GhcPs = NoExtCon
441 type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) (HsExpr GhcRn)
442 type instance XXExpr GhcTc = XXExprGhcTc
443 -- HsExpansion: see Note [Rebindable syntax and HsExpansion] below
444
445
446 data XXExprGhcTc
447 = WrapExpr -- Type and evidence application and abstractions
448 {-# UNPACK #-} !(HsWrap HsExpr)
449
450 | ExpansionExpr -- See Note [Rebindable syntax and HsExpansion] below
451 {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))
452
453 | ConLikeTc -- Result of typechecking a data-con
454 -- See Note [Typechecking data constructors] in
455 -- GHC.Tc.Gen.Head
456 -- The two arguments describe how to eta-expand
457 -- the data constructor when desugaring
458 ConLike [InvisTVBinder] [Scaled TcType]
459
460 ---------------------------------------
461 -- Haskell program coverage (Hpc) Support
462
463 | HsTick
464 CoreTickish
465 (LHsExpr GhcTc) -- sub-expression
466
467 | HsBinTick
468 Int -- module-local tick number for True
469 Int -- module-local tick number for False
470 (LHsExpr GhcTc) -- sub-expression
471
472
473 {- *********************************************************************
474 * *
475 Pretty-printing expressions
476 * *
477 ********************************************************************* -}
478
479 instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where
480 ppr expr = pprExpr expr
481
482 -----------------------
483 -- pprExpr, pprLExpr, pprBinds call pprDeeper;
484 -- the underscore versions do not
485 pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc
486 pprLExpr (L _ e) = pprExpr e
487
488 pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc
489 pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e
490 | otherwise = pprDeeper (ppr_expr e)
491
492 isQuietHsExpr :: HsExpr id -> Bool
493 -- Parentheses do display something, but it gives little info and
494 -- if we go deeper when we go inside them then we get ugly things
495 -- like (...)
496 isQuietHsExpr (HsPar {}) = True
497 -- applications don't display anything themselves
498 isQuietHsExpr (HsApp {}) = True
499 isQuietHsExpr (HsAppType {}) = True
500 isQuietHsExpr (OpApp {}) = True
501 isQuietHsExpr _ = False
502
503 pprBinds :: (OutputableBndrId idL, OutputableBndrId idR)
504 => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
505 pprBinds b = pprDeeper (ppr b)
506
507 -----------------------
508 ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc
509 ppr_lexpr e = ppr_expr (unLoc e)
510
511 ppr_expr :: forall p. (OutputableBndrId p)
512 => HsExpr (GhcPass p) -> SDoc
513 ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v
514 ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv
515 ppr_expr (HsRecSel _ f) = pprPrefixOcc f
516 ppr_expr (HsIPVar _ v) = ppr v
517 ppr_expr (HsOverLabel _ l) = char '#' <> ppr l
518 ppr_expr (HsLit _ lit) = ppr lit
519 ppr_expr (HsOverLit _ lit) = ppr lit
520 ppr_expr (HsPar _ _ e _) = parens (ppr_lexpr e)
521
522 ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e]
523
524 ppr_expr e@(HsApp {}) = ppr_apps e []
525 ppr_expr e@(HsAppType {}) = ppr_apps e []
526
527 ppr_expr (OpApp _ e1 op e2)
528 | Just pp_op <- ppr_infix_expr (unLoc op)
529 = pp_infixly pp_op
530 | otherwise
531 = pp_prefixly
532
533 where
534 pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens
535 pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear
536
537 pp_prefixly
538 = hang (ppr op) 2 (sep [pp_e1, pp_e2])
539
540 pp_infixly pp_op
541 = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])
542
543 ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e
544
545 ppr_expr (SectionL _ expr op)
546 | Just pp_op <- ppr_infix_expr (unLoc op)
547 = pp_infixly pp_op
548 | otherwise
549 = pp_prefixly
550 where
551 pp_expr = pprDebugParendExpr opPrec expr
552
553 pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
554 4 (hsep [pp_expr, text "x_ )"])
555
556 pp_infixly v = (sep [pp_expr, v])
557
558 ppr_expr (SectionR _ op expr)
559 | Just pp_op <- ppr_infix_expr (unLoc op)
560 = pp_infixly pp_op
561 | otherwise
562 = pp_prefixly
563 where
564 pp_expr = pprDebugParendExpr opPrec expr
565
566 pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])
567 4 (pp_expr <> rparen)
568
569 pp_infixly v = sep [v, pp_expr]
570
571 ppr_expr (ExplicitTuple _ exprs boxity)
572 -- Special-case unary boxed tuples so that they are pretty-printed as
573 -- `Solo x`, not `(x)`
574 | [Present _ expr] <- exprs
575 , Boxed <- boxity
576 = hsep [text (mkTupleStr Boxed 1), ppr expr]
577 | otherwise
578 = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args exprs))
579 where
580 ppr_tup_args [] = []
581 ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
582 ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
583
584 punc (Present {} : _) = comma <> space
585 punc (Missing {} : _) = comma
586 punc (XTupArg {} : _) = comma <> space
587 punc [] = empty
588
589 ppr_expr (ExplicitSum _ alt arity expr)
590 = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"
591 where
592 ppr_bars n = hsep (replicate n (char '|'))
593
594 ppr_expr (HsLam _ matches)
595 = pprMatches matches
596
597 ppr_expr (HsLamCase _ matches)
598 = sep [ sep [text "\\case"],
599 nest 2 (pprMatches matches) ]
600
601 ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts }))
602 = sep [ sep [text "case", nest 4 (ppr expr), text "of"],
603 pp_alts ]
604 where
605 pp_alts | null alts = text "{}"
606 | otherwise = nest 2 (pprMatches matches)
607
608 ppr_expr (HsIf _ e1 e2 e3)
609 = sep [hsep [text "if", nest 2 (ppr e1), text "then"],
610 nest 4 (ppr e2),
611 text "else",
612 nest 4 (ppr e3)]
613
614 ppr_expr (HsMultiIf _ alts)
615 = hang (text "if") 3 (vcat (map ppr_alt alts))
616 where ppr_alt (L _ (GRHS _ guards expr)) =
617 hang vbar 2 (ppr_one one_alt)
618 where
619 ppr_one [] = panic "ppr_exp HsMultiIf"
620 ppr_one (h:t) = hang h 2 (sep t)
621 one_alt = [ interpp'SP guards
622 , text "->" <+> pprDeeper (ppr expr) ]
623 ppr_alt (L _ (XGRHS x)) = ppr x
624
625 -- special case: let ... in let ...
626 ppr_expr (HsLet _ _ binds _ expr@(L _ (HsLet _ _ _ _ _)))
627 = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),
628 ppr_lexpr expr]
629
630 ppr_expr (HsLet _ _ binds _ expr)
631 = sep [hang (text "let") 2 (pprBinds binds),
632 hang (text "in") 2 (ppr expr)]
633
634 ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts
635
636 ppr_expr (ExplicitList _ exprs)
637 = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
638
639 ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds })
640 = hang pp_con 2 (ppr rbinds)
641 where
642 -- con :: ConLikeP (GhcPass p)
643 -- so we need case analysis to know to print it
644 pp_con = case ghcPass @p of
645 GhcPs -> ppr con
646 GhcRn -> ppr con
647 GhcTc -> ppr con
648
649 ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds })
650 = case flds of
651 Left rbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))
652 Right pbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds))))
653
654 ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field })
655 = ppr fexp <> dot <> ppr field
656
657 ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (dot : (punctuate dot (map ppr flds))))
658
659 ppr_expr (ExprWithTySig _ expr sig)
660 = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
661 4 (ppr sig)
662
663 ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
664
665 ppr_expr (HsSpliceE _ s) = pprSplice s
666 ppr_expr (HsBracket _ b) = pprHsBracket b
667 ppr_expr (HsRnBracketOut _ e []) = ppr e
668 ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
669 ppr_expr (HsTcBracketOut _ _wrap e []) = ppr e
670 ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> pprIfTc @p (ppr ps)
671
672 ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
673 = hsep [text "proc", ppr pat, text "->", ppr cmd]
674
675 ppr_expr (HsStatic _ e)
676 = hsep [text "static", ppr e]
677
678 ppr_expr (XExpr x) = case ghcPass @p of
679 #if __GLASGOW_HASKELL__ < 811
680 GhcPs -> ppr x
681 #endif
682 GhcRn -> ppr x
683 GhcTc -> ppr x
684
685 instance Outputable XXExprGhcTc where
686 ppr (WrapExpr (HsWrap co_fn e))
687 = pprHsWrapper co_fn (\_parens -> pprExpr e)
688
689 ppr (ExpansionExpr e)
690 = ppr e -- e is an HsExpansion, we print the original
691 -- expression (LHsExpr GhcPs), not the
692 -- desugared one (LHsExpr GhcTc).
693
694 ppr (ConLikeTc con _ _) = pprPrefixOcc con
695 -- Used in error messages generated by
696 -- the pattern match overlap checker
697
698 ppr (HsTick tickish exp) =
699 pprTicks (ppr exp) $
700 ppr tickish <+> ppr_lexpr exp
701
702 ppr (HsBinTick tickIdTrue tickIdFalse exp) =
703 pprTicks (ppr exp) $
704 hcat [text "bintick<",
705 ppr tickIdTrue,
706 text ",",
707 ppr tickIdFalse,
708 text ">(",
709 ppr exp, text ")"]
710
711 ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc
712 ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v)
713 ppr_infix_expr (HsRecSel _ f) = Just (pprInfixOcc f)
714 ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)
715 ppr_infix_expr (XExpr x) = case ghcPass @p of
716 #if __GLASGOW_HASKELL__ < 901
717 GhcPs -> Nothing
718 #endif
719 GhcRn -> ppr_infix_expr_rn x
720 GhcTc -> ppr_infix_expr_tc x
721 ppr_infix_expr _ = Nothing
722
723 ppr_infix_expr_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Maybe SDoc
724 ppr_infix_expr_rn (HsExpanded a _) = ppr_infix_expr a
725
726 ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
727 ppr_infix_expr_tc (WrapExpr (HsWrap _ e)) = ppr_infix_expr e
728 ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a
729 ppr_infix_expr_tc (ConLikeTc {}) = Nothing
730 ppr_infix_expr_tc (HsTick {}) = Nothing
731 ppr_infix_expr_tc (HsBinTick {}) = Nothing
732
733 ppr_apps :: (OutputableBndrId p)
734 => HsExpr (GhcPass p)
735 -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]
736 -> SDoc
737 ppr_apps (HsApp _ (L _ fun) arg) args
738 = ppr_apps fun (Left arg : args)
739 ppr_apps (HsAppType _ (L _ fun) arg) args
740 = ppr_apps fun (Right arg : args)
741 ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))
742 where
743 pp (Left arg) = ppr arg
744 -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
745 -- = char '@' <> pprHsType arg
746 pp (Right arg)
747 = text "@" <> ppr arg
748
749
750 pprDebugParendExpr :: (OutputableBndrId p)
751 => PprPrec -> LHsExpr (GhcPass p) -> SDoc
752 pprDebugParendExpr p expr
753 = getPprDebug $ \case
754 True -> pprParendLExpr p expr
755 False -> pprLExpr expr
756
757 pprParendLExpr :: (OutputableBndrId p)
758 => PprPrec -> LHsExpr (GhcPass p) -> SDoc
759 pprParendLExpr p (L _ e) = pprParendExpr p e
760
761 pprParendExpr :: (OutputableBndrId p)
762 => PprPrec -> HsExpr (GhcPass p) -> SDoc
763 pprParendExpr p expr
764 | hsExprNeedsParens p expr = parens (pprExpr expr)
765 | otherwise = pprExpr expr
766 -- Using pprLExpr makes sure that we go 'deeper'
767 -- I think that is usually (always?) right
768
769 -- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs
770 -- parentheses under precedence @p@.
771 hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool
772 hsExprNeedsParens prec = go
773 where
774 go :: HsExpr (GhcPass p) -> Bool
775 go (HsVar{}) = False
776 go (HsUnboundVar{}) = False
777 go (HsIPVar{}) = False
778 go (HsOverLabel{}) = False
779 go (HsLit _ l) = hsLitNeedsParens prec l
780 go (HsOverLit _ ol) = hsOverLitNeedsParens prec ol
781 go (HsPar{}) = False
782 go (HsApp{}) = prec >= appPrec
783 go (HsAppType {}) = prec >= appPrec
784 go (OpApp{}) = prec >= opPrec
785 go (NegApp{}) = prec > topPrec
786 go (SectionL{}) = True
787 go (SectionR{}) = True
788 -- Special-case unary boxed tuple applications so that they are
789 -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)
790 -- See Note [One-tuples] in GHC.Builtin.Types
791 go (ExplicitTuple _ [Present{}] Boxed)
792 = prec >= appPrec
793 go (ExplicitTuple{}) = False
794 go (ExplicitSum{}) = False
795 go (HsLam{}) = prec > topPrec
796 go (HsLamCase{}) = prec > topPrec
797 go (HsCase{}) = prec > topPrec
798 go (HsIf{}) = prec > topPrec
799 go (HsMultiIf{}) = prec > topPrec
800 go (HsLet{}) = prec > topPrec
801 go (HsDo _ sc _)
802 | isDoComprehensionContext sc = False
803 | otherwise = prec > topPrec
804 go (ExplicitList{}) = False
805 go (RecordUpd{}) = False
806 go (ExprWithTySig{}) = prec >= sigPrec
807 go (ArithSeq{}) = False
808 go (HsPragE{}) = prec >= appPrec
809 go (HsSpliceE{}) = False
810 go (HsBracket{}) = False
811 go (HsRnBracketOut{}) = False
812 go (HsTcBracketOut{}) = False
813 go (HsProc{}) = prec > topPrec
814 go (HsStatic{}) = prec >= appPrec
815 go (RecordCon{}) = False
816 go (HsRecSel{}) = False
817 go (HsProjection{}) = True
818 go (HsGetField{}) = False
819 go (XExpr x) = case ghcPass @p of
820 GhcTc -> go_x_tc x
821 GhcRn -> go_x_rn x
822 #if __GLASGOW_HASKELL__ <= 900
823 GhcPs -> True
824 #endif
825
826 go_x_tc :: XXExprGhcTc -> Bool
827 go_x_tc (WrapExpr (HsWrap _ e)) = hsExprNeedsParens prec e
828 go_x_tc (ExpansionExpr (HsExpanded a _)) = hsExprNeedsParens prec a
829 go_x_tc (ConLikeTc {}) = False
830 go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e
831 go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
832
833 go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool
834 go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a
835
836
837 -- | Parenthesize an expression without token information
838 gHsPar :: LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
839 gHsPar e = HsPar noAnn noHsTok e noHsTok
840
841 -- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,
842 -- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.
843 parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
844 parenthesizeHsExpr p le@(L loc e)
845 | hsExprNeedsParens p e = L loc (gHsPar le)
846 | otherwise = le
847
848 stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
849 stripParensLHsExpr (L _ (HsPar _ _ e _)) = stripParensLHsExpr e
850 stripParensLHsExpr e = e
851
852 stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p)
853 stripParensHsExpr (HsPar _ _ (L _ e) _) = stripParensHsExpr e
854 stripParensHsExpr e = e
855
856 isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool
857 -- True of a single token
858 isAtomicHsExpr (HsVar {}) = True
859 isAtomicHsExpr (HsLit {}) = True
860 isAtomicHsExpr (HsOverLit {}) = True
861 isAtomicHsExpr (HsIPVar {}) = True
862 isAtomicHsExpr (HsOverLabel {}) = True
863 isAtomicHsExpr (HsUnboundVar {}) = True
864 isAtomicHsExpr (HsRecSel{}) = True
865 isAtomicHsExpr (XExpr x)
866 | GhcTc <- ghcPass @p = go_x_tc x
867 | GhcRn <- ghcPass @p = go_x_rn x
868 where
869 go_x_tc (WrapExpr (HsWrap _ e)) = isAtomicHsExpr e
870 go_x_tc (ExpansionExpr (HsExpanded a _)) = isAtomicHsExpr a
871 go_x_tc (ConLikeTc {}) = True
872 go_x_tc (HsTick {}) = False
873 go_x_tc (HsBinTick {}) = False
874
875 go_x_rn (HsExpanded a _) = isAtomicHsExpr a
876
877 isAtomicHsExpr _ = False
878
879 instance Outputable (HsPragE (GhcPass p)) where
880 ppr (HsPragSCC _ st (StringLiteral stl lbl _)) =
881 pprWithSourceText st (text "{-# SCC")
882 -- no doublequotes if stl empty, for the case where the SCC was written
883 -- without quotes.
884 <+> pprWithSourceText stl (ftext lbl) <+> text "#-}"
885
886
887 {- *********************************************************************
888 * *
889 HsExpansion and rebindable syntax
890 * *
891 ********************************************************************* -}
892
893 {- Note [Rebindable syntax and HsExpansion]
894 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
895 We implement rebindable syntax (RS) support by performing a desugaring
896 in the renamer. We transform GhcPs expressions and patterns affected by
897 RS into the appropriate desugared form, but **annotated with the original
898 expression/pattern**.
899
900 Let us consider a piece of code like:
901
902 {-# LANGUAGE RebindableSyntax #-}
903 ifThenElse :: Char -> () -> () -> ()
904 ifThenElse _ _ _ = ()
905 x = if 'a' then () else True
906
907 The parsed AST for the RHS of x would look something like (slightly simplified):
908
909 L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True))
910
911 Upon seeing such an AST with RS on, we could transform it into a
912 mere function call, as per the RS rules, equivalent to the
913 following function application:
914
915 ifThenElse 'a' () True
916
917 which doesn't typecheck. But GHC would report an error about
918 not being able to match the third argument's type (Bool) with the
919 expected type: (), in the expression _as desugared_, i.e in
920 the aforementioned function application. But the user never
921 wrote a function application! This would be pretty bad.
922
923 To remedy this, instead of transforming the original HsIf
924 node into mere applications of 'ifThenElse', we keep the
925 original 'if' expression around too, using the TTG
926 XExpr extension point to allow GHC to construct an
927 'HsExpansion' value that will keep track of the original
928 expression in its first field, and the desugared one in the
929 second field. The resulting renamed AST would look like:
930
931 L locif (XExpr
932 (HsExpanded
933 (HsIf (L loca 'a')
934 (L loctrue ())
935 (L locfalse True)
936 )
937 (App (L generatedSrcSpan
938 (App (L generatedSrcSpan
939 (App (L generatedSrcSpan (Var ifThenElse))
940 (L loca 'a')
941 )
942 )
943 (L loctrue ())
944 )
945 )
946 (L locfalse True)
947 )
948 )
949 )
950
951 When comes the time to typecheck the program, we end up calling
952 tcMonoExpr on the AST above. If this expression gives rise to
953 a type error, then it will appear in a context line and GHC
954 will pretty-print it using the 'Outputable (HsExpansion a b)'
955 instance defined below, which *only prints the original
956 expression*. This is the gist of the idea, but is not quite
957 enough to recover the error messages that we had with the
958 SyntaxExpr-based, typechecking/desugaring-to-core time
959 implementation of rebindable syntax. The key idea is to decorate
960 some elements of the desugared expression so as to be able to
961 give them a special treatment when typechecking the desugared
962 expression, to print a different context line or skip one
963 altogether.
964
965 Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in
966 TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we
967 entered generated code, i.e code fabricated by the compiler when rebinding some
968 syntax. If someone tries to push some error context line while that field is set
969 to True, the pushing won't actually happen and the context line is just dropped.
970 Once we 'setSrcSpan' a real span (for an expression that was in the original
971 source code), we set 'tcl_in_gen_code' back to False, indicating that we
972 "emerged from the generated code tunnel", and that the expressions we will be
973 processing are relevant to report in context lines again.
974
975 You might wonder why TcLclEnv has both
976 tcl_loc :: RealSrcSpan
977 tcl_in_gen_code :: Bool
978 Could we not store a Maybe RealSrcSpan? The problem is that we still
979 generate constraints when processing generated code, and a CtLoc must
980 contain a RealSrcSpan -- otherwise, error messages might appear
981 without source locations. So tcl_loc keeps the RealSrcSpan of the last
982 location spotted that wasn't generated; it's as good as we're going to
983 get in generated code. Once we get to sub-trees that are not
984 generated, then we update the RealSrcSpan appropriately, and set the
985 tcl_in_gen_code Bool to False.
986
987 ---
988
989 An overview of the constructs that are desugared in this way is laid out in
990 Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.
991
992 A general recipe to follow this approach for new constructs could go as follows:
993
994 - Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your
995 construct, in HsExpr or related syntax data types.
996 - At renaming-time:
997 - take your original node of interest (HsIf above)
998 - rename its subexpressions/subpatterns (condition and true/false
999 branches above)
1000 - construct the suitable "rebound"-and-renamed result (ifThenElse call
1001 above), where the 'SrcSpan' attached to any _fabricated node_ (the
1002 HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'
1003 - take both the original node and that rebound-and-renamed result and wrap
1004 them into an expansion construct:
1005 for expressions, XExpr (HsExpanded <original node> <desugared>)
1006 for patterns, XPat (HsPatExpanded <original node> <desugared>)
1007 - At typechecking-time:
1008 - remove any logic that was previously dealing with your rebindable
1009 construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.
1010 - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we
1011 typecheck the desugared expression while reporting the original one in
1012 errors
1013 -}
1014
1015 {- Note [Overview of record dot syntax]
1016 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1017 This is the note that explains all the moving parts for record dot
1018 syntax.
1019
1020 The language extensions @OverloadedRecordDot@ and
1021 @OverloadedRecordUpdate@ (providing "record dot syntax") are
1022 implemented using the techniques of Note [Rebindable syntax and
1023 HsExpansion].
1024
1025 When OverloadedRecordDot is enabled:
1026 - Field selection expressions
1027 - e.g. foo.bar.baz
1028 - Have abstract syntax HsGetField
1029 - After renaming are XExpr (HsExpanded (HsGetField ...) (getField @"..."...)) expressions
1030 - Field selector expressions e.g. (.x.y)
1031 - Have abstract syntax HsProjection
1032 - After renaming are XExpr (HsExpanded (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions
1033
1034 When OverloadedRecordUpdate is enabled:
1035 - Record update expressions
1036 - e.g. a{foo.bar=1, quux="corge", baz}
1037 - Have abstract syntax RecordUpd
1038 - With rupd_flds containting a Right
1039 - See Note [RecordDotSyntax field updates] (in Language.Haskell.Syntax.Expr)
1040 - After renaming are XExpr (HsExpanded (RecordUpd ...) (setField@"..." ...) expressions
1041 - Note that this is true for all record updates even for those that do not involve '.'
1042
1043 When OverloadedRecordDot is enabled and RebindableSyntax is not
1044 enabled the name 'getField' is resolved to GHC.Records.getField. When
1045 OverloadedRecordDot is enabled and RebindableSyntax is enabled the
1046 name 'getField' is whatever in-scope name that is.
1047
1048 When OverloadedRecordUpd is enabled and RebindableSyntax is not
1049 enabled it is an error for now (temporary while we wait on native
1050 setField support; see
1051 https://gitlab.haskell.org/ghc/ghc/-/issues/16232). When
1052 OverloadedRecordUpd is enabled and RebindableSyntax is enabled the
1053 names 'getField' and 'setField' are whatever in-scope names they are.
1054 -}
1055
1056 -- See Note [Rebindable syntax and HsExpansion] just above.
1057 data HsExpansion orig expanded
1058 = HsExpanded orig expanded
1059 deriving Data
1060
1061 -- | Just print the original expression (the @a@).
1062 instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
1063 ppr (HsExpanded orig expanded)
1064 = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
1065 (ppr orig)
1066
1067
1068 {-
1069 ************************************************************************
1070 * *
1071 \subsection{Commands (in arrow abstractions)}
1072 * *
1073 ************************************************************************
1074 -}
1075
1076 type instance XCmdArrApp GhcPs = EpAnn AddEpAnn
1077 type instance XCmdArrApp GhcRn = NoExtField
1078 type instance XCmdArrApp GhcTc = Type
1079
1080 type instance XCmdArrForm GhcPs = EpAnn AnnList
1081 type instance XCmdArrForm GhcRn = NoExtField
1082 type instance XCmdArrForm GhcTc = NoExtField
1083
1084 type instance XCmdApp (GhcPass _) = EpAnnCO
1085 type instance XCmdLam (GhcPass _) = NoExtField
1086 type instance XCmdPar (GhcPass _) = EpAnnCO
1087
1088 type instance XCmdCase GhcPs = EpAnn EpAnnHsCase
1089 type instance XCmdCase GhcRn = NoExtField
1090 type instance XCmdCase GhcTc = NoExtField
1091
1092 type instance XCmdLamCase (GhcPass _) = EpAnn [AddEpAnn]
1093
1094 type instance XCmdIf GhcPs = EpAnn AnnsIf
1095 type instance XCmdIf GhcRn = NoExtField
1096 type instance XCmdIf GhcTc = NoExtField
1097
1098 type instance XCmdLet GhcPs = EpAnnCO
1099 type instance XCmdLet GhcRn = NoExtField
1100 type instance XCmdLet GhcTc = NoExtField
1101
1102 type instance XCmdDo GhcPs = EpAnn AnnList
1103 type instance XCmdDo GhcRn = NoExtField
1104 type instance XCmdDo GhcTc = Type
1105
1106 type instance XCmdWrap (GhcPass _) = NoExtField
1107
1108 type instance XXCmd GhcPs = NoExtCon
1109 type instance XXCmd GhcRn = NoExtCon
1110 type instance XXCmd GhcTc = HsWrap HsCmd
1111
1112 type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))]
1113 = SrcSpanAnnL
1114
1115 -- If cmd :: arg1 --> res
1116 -- wrap :: arg1 "->" arg2
1117 -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res
1118
1119 data CmdTopTc
1120 = CmdTopTc Type -- Nested tuple of inputs on the command's stack
1121 Type -- return type of the command
1122 (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]
1123
1124 type instance XCmdTop GhcPs = NoExtField
1125 type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]
1126 type instance XCmdTop GhcTc = CmdTopTc
1127
1128 type instance XXCmdTop (GhcPass _) = NoExtCon
1129
1130 instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where
1131 ppr cmd = pprCmd cmd
1132
1133 -----------------------
1134 -- pprCmd and pprLCmd call pprDeeper;
1135 -- the underscore versions do not
1136 pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc
1137 pprLCmd (L _ c) = pprCmd c
1138
1139 pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc
1140 pprCmd c | isQuietHsCmd c = ppr_cmd c
1141 | otherwise = pprDeeper (ppr_cmd c)
1142
1143 isQuietHsCmd :: HsCmd id -> Bool
1144 -- Parentheses do display something, but it gives little info and
1145 -- if we go deeper when we go inside them then we get ugly things
1146 -- like (...)
1147 isQuietHsCmd (HsCmdPar {}) = True
1148 -- applications don't display anything themselves
1149 isQuietHsCmd (HsCmdApp {}) = True
1150 isQuietHsCmd _ = False
1151
1152 -----------------------
1153 ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc
1154 ppr_lcmd c = ppr_cmd (unLoc c)
1155
1156 ppr_cmd :: forall p. (OutputableBndrId p
1157 ) => HsCmd (GhcPass p) -> SDoc
1158 ppr_cmd (HsCmdPar _ _ c _) = parens (ppr_lcmd c)
1159
1160 ppr_cmd (HsCmdApp _ c e)
1161 = let (fun, args) = collect_args c [e] in
1162 hang (ppr_lcmd fun) 2 (sep (map ppr args))
1163 where
1164 collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args)
1165 collect_args fun args = (fun, args)
1166
1167 ppr_cmd (HsCmdLam _ matches)
1168 = pprMatches matches
1169
1170 ppr_cmd (HsCmdCase _ expr matches)
1171 = sep [ sep [text "case", nest 4 (ppr expr), text "of"],
1172 nest 2 (pprMatches matches) ]
1173
1174 ppr_cmd (HsCmdLamCase _ matches)
1175 = sep [ text "\\case", nest 2 (pprMatches matches) ]
1176
1177 ppr_cmd (HsCmdIf _ _ e ct ce)
1178 = sep [hsep [text "if", nest 2 (ppr e), text "then"],
1179 nest 4 (ppr ct),
1180 text "else",
1181 nest 4 (ppr ce)]
1182
1183 -- special case: let ... in let ...
1184 ppr_cmd (HsCmdLet _ _ binds _ cmd@(L _ (HsCmdLet {})))
1185 = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),
1186 ppr_lcmd cmd]
1187
1188 ppr_cmd (HsCmdLet _ _ binds _ cmd)
1189 = sep [hang (text "let") 2 (pprBinds binds),
1190 hang (text "in") 2 (ppr cmd)]
1191
1192 ppr_cmd (HsCmdDo _ (L _ stmts)) = pprArrowExpr stmts
1193
1194 ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)
1195 = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
1196 ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)
1197 = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]
1198 ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)
1199 = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]
1200 ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)
1201 = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
1202
1203 ppr_cmd (HsCmdArrForm _ (L _ op) ps_fix rn_fix args)
1204 | HsVar _ (L _ v) <- op
1205 = ppr_cmd_infix v
1206 | GhcTc <- ghcPass @p
1207 , XExpr (ConLikeTc c _ _) <- op
1208 = ppr_cmd_infix (conLikeName c)
1209 | otherwise
1210 = fall_through
1211 where
1212 fall_through = hang (text "(|" <+> ppr_expr op)
1213 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
1214
1215 ppr_cmd_infix :: OutputableBndr v => v -> SDoc
1216 ppr_cmd_infix v
1217 | [arg1, arg2] <- args
1218 , isJust rn_fix || ps_fix == Infix
1219 = hang (pprCmdArg (unLoc arg1))
1220 4 (sep [ pprInfixOcc v, pprCmdArg (unLoc arg2)])
1221 | otherwise
1222 = fall_through
1223
1224 ppr_cmd (XCmd x) = case ghcPass @p of
1225 #if __GLASGOW_HASKELL__ < 811
1226 GhcPs -> ppr x
1227 GhcRn -> ppr x
1228 #endif
1229 GhcTc -> case x of
1230 HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd))
1231
1232 pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc
1233 pprCmdArg (HsCmdTop _ cmd)
1234 = ppr_lcmd cmd
1235
1236 instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where
1237 ppr = pprCmdArg
1238
1239 {-
1240 ************************************************************************
1241 * *
1242 \subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
1243 * *
1244 ************************************************************************
1245 -}
1246
1247 type instance XMG GhcPs b = NoExtField
1248 type instance XMG GhcRn b = NoExtField
1249 type instance XMG GhcTc b = MatchGroupTc
1250
1251 type instance XXMatchGroup (GhcPass _) b = NoExtCon
1252
1253 type instance XCMatch (GhcPass _) b = EpAnn [AddEpAnn]
1254 type instance XXMatch (GhcPass _) b = NoExtCon
1255
1256 instance (OutputableBndrId pr, Outputable body)
1257 => Outputable (Match (GhcPass pr) body) where
1258 ppr = pprMatch
1259
1260 isEmptyMatchGroup :: MatchGroup (GhcPass p) body -> Bool
1261 isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
1262
1263 -- | Is there only one RHS in this list of matches?
1264 isSingletonMatchGroup :: [LMatch (GhcPass p) body] -> Bool
1265 isSingletonMatchGroup matches
1266 | [L _ match] <- matches
1267 , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match
1268 = True
1269 | otherwise
1270 = False
1271
1272 matchGroupArity :: MatchGroup (GhcPass id) body -> Arity
1273 -- Precondition: MatchGroup is non-empty
1274 -- This is called before type checking, when mg_arg_tys is not set
1275 matchGroupArity (MG { mg_alts = alts })
1276 | L _ (alt1:_) <- alts = length (hsLMatchPats alt1)
1277 | otherwise = panic "matchGroupArity"
1278
1279 hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]
1280 hsLMatchPats (L _ (Match { m_pats = pats })) = pats
1281
1282 -- We keep the type checker happy by providing EpAnnComments. They
1283 -- can only be used if they follow a `where` keyword with no binds,
1284 -- but in that case the comment is attached to the following parsed
1285 -- item. So this can never be used in practice.
1286 type instance XCGRHSs (GhcPass _) _ = EpAnnComments
1287
1288 type instance XXGRHSs (GhcPass _) _ = NoExtCon
1289
1290 data GrhsAnn
1291 = GrhsAnn {
1292 ga_vbar :: Maybe EpaLocation, -- TODO:AZ do we need this?
1293 ga_sep :: AddEpAnn -- ^ Match separator location
1294 } deriving (Data)
1295
1296 type instance XCGRHS (GhcPass _) _ = EpAnn GrhsAnn
1297 -- Location of matchSeparator
1298 -- TODO:AZ does this belong on the GRHS, or GRHSs?
1299
1300 type instance XXGRHS (GhcPass _) b = NoExtCon
1301
1302 pprMatches :: (OutputableBndrId idR, Outputable body)
1303 => MatchGroup (GhcPass idR) body -> SDoc
1304 pprMatches MG { mg_alts = matches }
1305 = vcat (map pprMatch (map unLoc (unLoc matches)))
1306 -- Don't print the type; it's only a place-holder before typechecking
1307
1308 -- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext
1309 pprFunBind :: (OutputableBndrId idR)
1310 => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc
1311 pprFunBind matches = pprMatches matches
1312
1313 -- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext
1314 pprPatBind :: forall bndr p . (OutputableBndrId bndr,
1315 OutputableBndrId p)
1316 => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc
1317 pprPatBind pat grhss
1318 = sep [ppr pat,
1319 nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)]
1320
1321 pprMatch :: (OutputableBndrId idR, Outputable body)
1322 => Match (GhcPass idR) body -> SDoc
1323 pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
1324 = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)
1325 , nest 2 (pprGRHSs ctxt grhss) ]
1326 where
1327 (herald, other_pats)
1328 = case ctxt of
1329 FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}
1330 | SrcStrict <- strictness
1331 -> assert (null pats) -- A strict variable binding
1332 (char '!'<>pprPrefixOcc fun, pats)
1333
1334 | Prefix <- fixity
1335 -> (pprPrefixOcc fun, pats) -- f x y z = e
1336 -- Not pprBndr; the AbsBinds will
1337 -- have printed the signature
1338 | otherwise
1339 -> case pats of
1340 (p1:p2:rest)
1341 | null rest -> (pp_infix, []) -- x &&& y = e
1342 | otherwise -> (parens pp_infix, rest) -- (x &&& y) z = e
1343 where
1344 pp_infix = pprParendLPat opPrec p1
1345 <+> pprInfixOcc fun
1346 <+> pprParendLPat opPrec p2
1347 _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)
1348
1349 LambdaExpr -> (char '\\', pats)
1350
1351 _ -> case pats of
1352 [] -> (empty, [])
1353 [pat] -> (ppr pat, []) -- No parens around the single pat in a case
1354 _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)
1355
1356 pprGRHSs :: (OutputableBndrId idR, Outputable body)
1357 => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc
1358 pprGRHSs ctxt (GRHSs _ grhss binds)
1359 = vcat (map (pprGRHS ctxt . unLoc) grhss)
1360 -- Print the "where" even if the contents of the binds is empty. Only
1361 -- EmptyLocalBinds means no "where" keyword
1362 $$ ppUnless (eqEmptyLocalBinds binds)
1363 (text "where" $$ nest 4 (pprBinds binds))
1364
1365 pprGRHS :: (OutputableBndrId idR, Outputable body)
1366 => HsMatchContext passL -> GRHS (GhcPass idR) body -> SDoc
1367 pprGRHS ctxt (GRHS _ [] body)
1368 = pp_rhs ctxt body
1369
1370 pprGRHS ctxt (GRHS _ guards body)
1371 = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]
1372
1373 pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc
1374 pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
1375
1376 instance Outputable GrhsAnn where
1377 ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s
1378
1379 {-
1380 ************************************************************************
1381 * *
1382 \subsection{Do stmts and list comprehensions}
1383 * *
1384 ************************************************************************
1385 -}
1386
1387 -- Extra fields available post typechecking for RecStmt.
1388 data RecStmtTc =
1389 RecStmtTc
1390 { recS_bind_ty :: Type -- S in (>>=) :: Q -> (R -> S) -> T
1391 , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)
1392 , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1
1393 -- with recS_later_ids and recS_rec_ids,
1394 -- and are the expressions that should be
1395 -- returned by the recursion.
1396 -- They may not quite be the Ids themselves,
1397 -- because the Id may be *polymorphic*, but
1398 -- the returned thing has to be *monomorphic*,
1399 -- so they may be type applications
1400
1401 , recS_ret_ty :: Type -- The type of
1402 -- do { stmts; return (a,b,c) }
1403 -- With rebindable syntax the type might not
1404 -- be quite as simple as (m (tya, tyb, tyc)).
1405 }
1406
1407
1408 type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField
1409
1410 type instance XBindStmt (GhcPass _) GhcPs b = EpAnn [AddEpAnn]
1411 type instance XBindStmt (GhcPass _) GhcRn b = XBindStmtRn
1412 type instance XBindStmt (GhcPass _) GhcTc b = XBindStmtTc
1413
1414 data XBindStmtRn = XBindStmtRn
1415 { xbsrn_bindOp :: SyntaxExpr GhcRn
1416 , xbsrn_failOp :: FailOperator GhcRn
1417 }
1418
1419 data XBindStmtTc = XBindStmtTc
1420 { xbstc_bindOp :: SyntaxExpr GhcTc
1421 , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S
1422 , xbstc_boundResultMult :: Mult -- If (>>=) :: Q -> (R -> S) -> T, this is S
1423 , xbstc_failOp :: FailOperator GhcTc
1424 }
1425
1426 type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField
1427 type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField
1428 type instance XApplicativeStmt (GhcPass _) GhcTc b = Type
1429
1430 type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField
1431 type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField
1432 type instance XBodyStmt (GhcPass _) GhcTc b = Type
1433
1434 type instance XLetStmt (GhcPass _) (GhcPass _) b = EpAnn [AddEpAnn]
1435
1436 type instance XParStmt (GhcPass _) GhcPs b = NoExtField
1437 type instance XParStmt (GhcPass _) GhcRn b = NoExtField
1438 type instance XParStmt (GhcPass _) GhcTc b = Type
1439
1440 type instance XTransStmt (GhcPass _) GhcPs b = EpAnn [AddEpAnn]
1441 type instance XTransStmt (GhcPass _) GhcRn b = NoExtField
1442 type instance XTransStmt (GhcPass _) GhcTc b = Type
1443
1444 type instance XRecStmt (GhcPass _) GhcPs b = EpAnn AnnList
1445 type instance XRecStmt (GhcPass _) GhcRn b = NoExtField
1446 type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc
1447
1448 type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExtCon
1449
1450 type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtField
1451 type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon
1452
1453 type instance XApplicativeArgOne GhcPs = NoExtField
1454 type instance XApplicativeArgOne GhcRn = FailOperator GhcRn
1455 type instance XApplicativeArgOne GhcTc = FailOperator GhcTc
1456
1457 type instance XApplicativeArgMany (GhcPass _) = NoExtField
1458 type instance XXApplicativeArg (GhcPass _) = NoExtCon
1459
1460 instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))),
1461 Outputable (XXParStmtBlock (GhcPass idL) (GhcPass idR)))
1462 => Outputable (ParStmtBlock (GhcPass idL) (GhcPass idR)) where
1463 ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts
1464
1465 instance (OutputableBndrId pl, OutputableBndrId pr,
1466 Anno (StmtLR (GhcPass pl) (GhcPass pr) body) ~ SrcSpanAnnA,
1467 Outputable body)
1468 => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where
1469 ppr stmt = pprStmt stmt
1470
1471 pprStmt :: forall idL idR body . (OutputableBndrId idL,
1472 OutputableBndrId idR,
1473 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,
1474 Outputable body)
1475 => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc
1476 pprStmt (LastStmt _ expr m_dollar_stripped _)
1477 = whenPprDebug (text "[last]") <+>
1478 (case m_dollar_stripped of
1479 Just True -> text "return $"
1480 Just False -> text "return"
1481 Nothing -> empty) <+>
1482 ppr expr
1483 pprStmt (BindStmt _ pat expr) = pprBindStmt pat expr
1484 pprStmt (LetStmt _ binds) = hsep [text "let", pprBinds binds]
1485 pprStmt (BodyStmt _ expr _ _) = ppr expr
1486 pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss))
1487
1488 pprStmt (TransStmt { trS_stmts = stmts, trS_by = by
1489 , trS_using = using, trS_form = form })
1490 = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])
1491
1492 pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
1493 , recS_later_ids = later_ids })
1494 = text "rec" <+>
1495 vcat [ ppr_do_stmts (unLoc segment)
1496 , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids
1497 , text "later_ids=" <> ppr later_ids])]
1498
1499 pprStmt (ApplicativeStmt _ args mb_join)
1500 = getPprStyle $ \style ->
1501 if userStyle style
1502 then pp_for_user
1503 else pp_debug
1504 where
1505 -- make all the Applicative stuff invisible in error messages by
1506 -- flattening the whole ApplicativeStmt nest back to a sequence
1507 -- of statements.
1508 pp_for_user = vcat $ concatMap flattenArg args
1509
1510 -- ppr directly rather than transforming here, because we need to
1511 -- inject a "return" which is hard when we're polymorphic in the id
1512 -- type.
1513 flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]
1514 flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args
1515 flattenStmt stmt = [ppr stmt]
1516
1517 flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
1518 flattenArg (_, ApplicativeArgOne _ pat expr isBody)
1519 | isBody = [ppr expr] -- See Note [Applicative BodyStmt]
1520 | otherwise = [pprBindStmt pat expr]
1521 flattenArg (_, ApplicativeArgMany _ stmts _ _ _) =
1522 concatMap flattenStmt stmts
1523
1524 pp_debug =
1525 let
1526 ap_expr = sep (punctuate (text " |") (map pp_arg args))
1527 in
1528 whenPprDebug (if isJust mb_join then text "[join]" else empty) <+>
1529 (if lengthAtLeast args 2 then parens else id) ap_expr
1530
1531 pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
1532 pp_arg (_, applicativeArg) = ppr applicativeArg
1533
1534 pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc
1535 pprBindStmt pat expr = hsep [ppr pat, larrow, ppr expr]
1536
1537 instance (OutputableBndrId idL)
1538 => Outputable (ApplicativeArg (GhcPass idL)) where
1539 ppr = pprArg
1540
1541 pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc
1542 pprArg (ApplicativeArgOne _ pat expr isBody)
1543 | isBody = ppr expr -- See Note [Applicative BodyStmt]
1544 | otherwise = pprBindStmt pat expr
1545 pprArg (ApplicativeArgMany _ stmts return pat ctxt) =
1546 ppr pat <+>
1547 text "<-" <+>
1548 pprDo ctxt (stmts ++
1549 [noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)])
1550
1551 pprTransformStmt :: (OutputableBndrId p)
1552 => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
1553 -> Maybe (LHsExpr (GhcPass p)) -> SDoc
1554 pprTransformStmt bndrs using by
1555 = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))
1556 , nest 2 (ppr using)
1557 , nest 2 (pprBy by)]
1558
1559 pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc
1560 pprTransStmt by using ThenForm
1561 = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)]
1562 pprTransStmt by using GroupForm
1563 = sep [ text "then group", nest 2 (pprBy by), nest 2 (text "using" <+> ppr using)]
1564
1565 pprBy :: Outputable body => Maybe body -> SDoc
1566 pprBy Nothing = empty
1567 pprBy (Just e) = text "by" <+> ppr e
1568
1569 pprDo :: (OutputableBndrId p, Outputable body,
1570 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA
1571 )
1572 => HsDoFlavour -> [LStmt (GhcPass p) body] -> SDoc
1573 pprDo (DoExpr m) stmts =
1574 ppr_module_name_prefix m <> text "do" <+> ppr_do_stmts stmts
1575 pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts
1576 pprDo (MDoExpr m) stmts =
1577 ppr_module_name_prefix m <> text "mdo" <+> ppr_do_stmts stmts
1578 pprDo ListComp stmts = brackets $ pprComp stmts
1579 pprDo MonadComp stmts = brackets $ pprComp stmts
1580
1581 pprArrowExpr :: (OutputableBndrId p, Outputable body,
1582 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA
1583 )
1584 => [LStmt (GhcPass p) body] -> SDoc
1585 pprArrowExpr stmts = text "do" <+> ppr_do_stmts stmts
1586
1587 ppr_module_name_prefix :: Maybe ModuleName -> SDoc
1588 ppr_module_name_prefix = \case
1589 Nothing -> empty
1590 Just module_name -> ppr module_name <> char '.'
1591
1592 ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR,
1593 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,
1594 Outputable body)
1595 => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc
1596 -- Print a bunch of do stmts
1597 ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)
1598
1599 pprComp :: (OutputableBndrId p, Outputable body,
1600 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)
1601 => [LStmt (GhcPass p) body] -> SDoc
1602 pprComp quals -- Prints: body | qual1, ..., qualn
1603 | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals
1604 = if null initStmts
1605 -- If there are no statements in a list comprehension besides the last
1606 -- one, we simply treat it like a normal list. This does arise
1607 -- occasionally in code that GHC generates, e.g., in implementations of
1608 -- 'range' for derived 'Ix' instances for product datatypes with exactly
1609 -- one constructor (e.g., see #12583).
1610 then ppr body
1611 else hang (ppr body <+> vbar) 2 (pprQuals initStmts)
1612 | otherwise
1613 = pprPanic "pprComp" (pprQuals quals)
1614
1615 pprQuals :: (OutputableBndrId p, Outputable body,
1616 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)
1617 => [LStmt (GhcPass p) body] -> SDoc
1618 -- Show list comprehension qualifiers separated by commas
1619 pprQuals quals = interpp'SP quals
1620
1621 {-
1622 ************************************************************************
1623 * *
1624 Template Haskell quotation brackets
1625 * *
1626 ************************************************************************
1627 -}
1628
1629 newtype HsSplicedT = HsSplicedT DelayedSplice deriving (Data)
1630
1631 type instance XTypedSplice (GhcPass _) = EpAnn [AddEpAnn]
1632 type instance XUntypedSplice (GhcPass _) = EpAnn [AddEpAnn]
1633 type instance XQuasiQuote (GhcPass _) = NoExtField
1634 type instance XSpliced (GhcPass _) = NoExtField
1635 type instance XXSplice GhcPs = NoExtCon
1636 type instance XXSplice GhcRn = NoExtCon
1637 type instance XXSplice GhcTc = HsSplicedT
1638
1639 -- See Note [Running typed splices in the zonker]
1640 -- These are the arguments that are passed to `GHC.Tc.Gen.Splice.runTopSplice`
1641 data DelayedSplice =
1642 DelayedSplice
1643 TcLclEnv -- The local environment to run the splice in
1644 (LHsExpr GhcRn) -- The original renamed expression
1645 TcType -- The result type of running the splice, unzonked
1646 (LHsExpr GhcTc) -- The typechecked expression to run and splice in the result
1647
1648 -- A Data instance which ignores the argument of 'DelayedSplice'.
1649 instance Data DelayedSplice where
1650 gunfold _ _ _ = panic "DelayedSplice"
1651 toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix
1652 dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [toConstr a]
1653
1654 -- | Pending Renamer Splice
1655 data PendingRnSplice
1656 = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)
1657
1658 -- | Pending Type-checker Splice
1659 data PendingTcSplice
1660 = PendingTcSplice SplicePointName (LHsExpr GhcTc)
1661
1662 {-
1663 Note [Pending Splices]
1664 ~~~~~~~~~~~~~~~~~~~~~~
1665 When we rename an untyped bracket, we name and lift out all the nested
1666 splices, so that when the typechecker hits the bracket, it can
1667 typecheck those nested splices without having to walk over the untyped
1668 bracket code. So for example
1669 [| f $(g x) |]
1670 looks like
1671
1672 HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x)))
1673
1674 which the renamer rewrites to
1675
1676 HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x)))
1677 [PendingRnSplice UntypedExpSplice sn (g x)]
1678
1679 * The 'sn' is the Name of the splice point, the SplicePointName
1680
1681 * The PendingRnExpSplice gives the splice that splice-point name maps to;
1682 and the typechecker can now conveniently find these sub-expressions
1683
1684 * The other copy of the splice, in the second argument of HsSpliceE
1685 in the renamed first arg of HsRnBracketOut
1686 is used only for pretty printing
1687
1688 There are four varieties of pending splices generated by the renamer,
1689 distinguished by their UntypedSpliceFlavour
1690
1691 * Pending expression splices (UntypedExpSplice), e.g.,
1692 [|$(f x) + 2|]
1693
1694 UntypedExpSplice is also used for
1695 * quasi-quotes, where the pending expression expands to
1696 $(quoter "...blah...")
1697 (see GHC.Rename.Splice.makePending, HsQuasiQuote case)
1698
1699 * cross-stage lifting, where the pending expression expands to
1700 $(lift x)
1701 (see GHC.Rename.Splice.checkCrossStageLifting)
1702
1703 * Pending pattern splices (UntypedPatSplice), e.g.,
1704 [| \$(f x) -> x |]
1705
1706 * Pending type splices (UntypedTypeSplice), e.g.,
1707 [| f :: $(g x) |]
1708
1709 * Pending declaration (UntypedDeclSplice), e.g.,
1710 [| let $(f x) in ... |]
1711
1712 There is a fifth variety of pending splice, which is generated by the type
1713 checker:
1714
1715 * Pending *typed* expression splices, (PendingTcSplice), e.g.,
1716 [||1 + $$(f 2)||]
1717
1718 It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the
1719 output of the renamer. However, when pretty printing the output of the renamer,
1720 e.g., in a type error message, we *do not* want to print out the pending
1721 splices. In contrast, when pretty printing the output of the type checker, we
1722 *do* want to print the pending splices. So splitting them up seems to make
1723 sense, although I hate to add another constructor to HsExpr.
1724 -}
1725
1726 instance OutputableBndrId p
1727 => Outputable (HsSplicedThing (GhcPass p)) where
1728 ppr (HsSplicedExpr e) = ppr_expr e
1729 ppr (HsSplicedTy t) = ppr t
1730 ppr (HsSplicedPat p) = ppr p
1731
1732 instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where
1733 ppr s = pprSplice s
1734
1735 pprPendingSplice :: (OutputableBndrId p)
1736 => SplicePointName -> LHsExpr (GhcPass p) -> SDoc
1737 pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e))
1738
1739 pprSpliceDecl :: (OutputableBndrId p)
1740 => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc
1741 pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e
1742 pprSpliceDecl e ExplicitSplice = text "$" <> ppr_splice_decl e
1743 pprSpliceDecl e ImplicitSplice = ppr_splice_decl e
1744
1745 ppr_splice_decl :: (OutputableBndrId p)
1746 => HsSplice (GhcPass p) -> SDoc
1747 ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty
1748 ppr_splice_decl e = pprSplice e
1749
1750 pprSplice :: forall p. (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc
1751 pprSplice (HsTypedSplice _ DollarSplice n e)
1752 = ppr_splice (text "$$") n e empty
1753 pprSplice (HsTypedSplice _ BareSplice _ _ )
1754 = panic "Bare typed splice" -- impossible
1755 pprSplice (HsUntypedSplice _ DollarSplice n e)
1756 = ppr_splice (text "$") n e empty
1757 pprSplice (HsUntypedSplice _ BareSplice n e)
1758 = ppr_splice empty n e empty
1759 pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s
1760 pprSplice (HsSpliced _ _ thing) = ppr thing
1761 pprSplice (XSplice x) = case ghcPass @p of
1762 #if __GLASGOW_HASKELL__ < 811
1763 GhcPs -> noExtCon x
1764 GhcRn -> noExtCon x
1765 #endif
1766 GhcTc -> case x of
1767 HsSplicedT _ -> text "Unevaluated typed splice"
1768
1769 ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc
1770 ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>
1771 char '[' <> ppr quoter <> vbar <>
1772 ppr quote <> text "|]"
1773
1774 ppr_splice :: (OutputableBndrId p)
1775 => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc
1776 ppr_splice herald n e trail
1777 = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail
1778
1779 type instance XExpBr (GhcPass _) = NoExtField
1780 type instance XPatBr (GhcPass _) = NoExtField
1781 type instance XDecBrL (GhcPass _) = NoExtField
1782 type instance XDecBrG (GhcPass _) = NoExtField
1783 type instance XTypBr (GhcPass _) = NoExtField
1784 type instance XVarBr (GhcPass _) = NoExtField
1785 type instance XTExpBr (GhcPass _) = NoExtField
1786 type instance XXBracket (GhcPass _) = NoExtCon
1787
1788 instance OutputableBndrId p
1789 => Outputable (HsBracket (GhcPass p)) where
1790 ppr = pprHsBracket
1791
1792
1793 pprHsBracket :: (OutputableBndrId p) => HsBracket (GhcPass p) -> SDoc
1794 pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e)
1795 pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p)
1796 pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)
1797 pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))
1798 pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t)
1799 pprHsBracket (VarBr _ True n)
1800 = char '\'' <> pprPrefixOcc (unLoc n)
1801 pprHsBracket (VarBr _ False n)
1802 = text "''" <> pprPrefixOcc (unLoc n)
1803 pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e)
1804
1805 thBrackets :: SDoc -> SDoc -> SDoc
1806 thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
1807 pp_body <+> text "|]"
1808
1809 thTyBrackets :: SDoc -> SDoc
1810 thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]"
1811
1812 instance Outputable PendingRnSplice where
1813 ppr (PendingRnSplice _ n e) = pprPendingSplice n e
1814
1815 instance Outputable PendingTcSplice where
1816 ppr (PendingTcSplice n e) = pprPendingSplice n e
1817
1818 {-
1819 ************************************************************************
1820 * *
1821 \subsection{Enumerations and list comprehensions}
1822 * *
1823 ************************************************************************
1824 -}
1825
1826 instance OutputableBndrId p
1827 => Outputable (ArithSeqInfo (GhcPass p)) where
1828 ppr (From e1) = hcat [ppr e1, pp_dotdot]
1829 ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
1830 ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3]
1831 ppr (FromThenTo e1 e2 e3)
1832 = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]
1833
1834 pp_dotdot :: SDoc
1835 pp_dotdot = text " .. "
1836
1837 {-
1838 ************************************************************************
1839 * *
1840 \subsection{HsMatchCtxt}
1841 * *
1842 ************************************************************************
1843 -}
1844
1845 instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where
1846 ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)
1847 ppr LambdaExpr = text "LambdaExpr"
1848 ppr CaseAlt = text "CaseAlt"
1849 ppr IfAlt = text "IfAlt"
1850 ppr (ArrowMatchCtxt c) = text "ArrowMatchCtxt" <+> ppr c
1851 ppr PatBindRhs = text "PatBindRhs"
1852 ppr PatBindGuards = text "PatBindGuards"
1853 ppr RecUpd = text "RecUpd"
1854 ppr (StmtCtxt _) = text "StmtCtxt _"
1855 ppr ThPatSplice = text "ThPatSplice"
1856 ppr ThPatQuote = text "ThPatQuote"
1857 ppr PatSyn = text "PatSyn"
1858
1859 instance Outputable HsArrowMatchContext where
1860 ppr ProcExpr = text "ProcExpr"
1861 ppr ArrowCaseAlt = text "ArrowCaseAlt"
1862 ppr KappaExpr = text "KappaExpr"
1863
1864 -----------------
1865
1866 instance OutputableBndrId p
1867 => Outputable (HsStmtContext (GhcPass p)) where
1868 ppr = pprStmtContext
1869
1870 -- Used to generate the string for a *runtime* error message
1871 matchContextErrString :: OutputableBndrId p
1872 => HsMatchContext (GhcPass p) -> SDoc
1873 matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun
1874 matchContextErrString CaseAlt = text "case"
1875 matchContextErrString IfAlt = text "multi-way if"
1876 matchContextErrString PatBindRhs = text "pattern binding"
1877 matchContextErrString PatBindGuards = text "pattern binding guards"
1878 matchContextErrString RecUpd = text "record update"
1879 matchContextErrString LambdaExpr = text "lambda"
1880 matchContextErrString (ArrowMatchCtxt c) = matchArrowContextErrString c
1881 matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime
1882 matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime
1883 matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime
1884 matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
1885 matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
1886 matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard"
1887 matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block"
1888 matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour
1889
1890 matchArrowContextErrString :: HsArrowMatchContext -> SDoc
1891 matchArrowContextErrString ProcExpr = text "proc"
1892 matchArrowContextErrString ArrowCaseAlt = text "case"
1893 matchArrowContextErrString KappaExpr = text "kappa"
1894
1895 matchDoContextErrString :: HsDoFlavour -> SDoc
1896 matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command"
1897 matchDoContextErrString (DoExpr m) = prependQualified m (text "'do' block")
1898 matchDoContextErrString (MDoExpr m) = prependQualified m (text "'mdo' block")
1899 matchDoContextErrString ListComp = text "list comprehension"
1900 matchDoContextErrString MonadComp = text "monad comprehension"
1901
1902 pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)
1903 => Match (GhcPass idR) body -> SDoc
1904 pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
1905 <> colon)
1906 4 (pprMatch match)
1907
1908 pprStmtInCtxt :: (OutputableBndrId idL,
1909 OutputableBndrId idR,
1910 OutputableBndrId ctx,
1911 Outputable body,
1912 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)
1913 => HsStmtContext (GhcPass ctx)
1914 -> StmtLR (GhcPass idL) (GhcPass idR) body
1915 -> SDoc
1916 pprStmtInCtxt ctxt (LastStmt _ e _ _)
1917 | isComprehensionContext ctxt -- For [ e | .. ], do not mutter about "stmts"
1918 = hang (text "In the expression:") 2 (ppr e)
1919
1920 pprStmtInCtxt ctxt stmt
1921 = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon)
1922 2 (ppr_stmt stmt)
1923 where
1924 -- For Group and Transform Stmts, don't print the nested stmts!
1925 ppr_stmt (TransStmt { trS_by = by, trS_using = using
1926 , trS_form = form }) = pprTransStmt by using form
1927 ppr_stmt stmt = pprStmt stmt
1928
1929 {-
1930 ************************************************************************
1931 * *
1932 \subsection{Anno instances}
1933 * *
1934 ************************************************************************
1935 -}
1936
1937 type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA
1938 type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))))] = SrcSpanAnnL
1939 type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))))] = SrcSpanAnnL
1940
1941 type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA
1942
1943 type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))]
1944 = SrcSpanAnnL
1945 type instance Anno (HsCmdTop (GhcPass p)) = SrcAnn NoEpAnns
1946 type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnL
1947 type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p))))] = SrcSpanAnnL
1948 type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA
1949 type instance Anno (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcSpanAnnA
1950 type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcAnn NoEpAnns
1951 type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcAnn NoEpAnns
1952 type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))) = SrcSpanAnnA
1953 type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))) = SrcSpanAnnA
1954
1955 type instance Anno (HsSplice (GhcPass p)) = SrcSpanAnnA
1956
1957 type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnL
1958 type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnL
1959
1960 type instance Anno (FieldLabelStrings (GhcPass p)) = SrcAnn NoEpAnns
1961 type instance Anno (FieldLabelString) = SrcAnn NoEpAnns
1962 type instance Anno (DotFieldOcc (GhcPass p)) = SrcAnn NoEpAnns
1963
1964 instance (Anno a ~ SrcSpanAnn' (EpAnn an))
1965 => WrapXRec (GhcPass p) a where
1966 wrapXRec = noLocA