HsExpr.lhs 42.7 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
%
\begin{code}
6
7

-- | Abstract Haskell syntax for expressions.
8
9
module HsExpr where

10
#include "HsVersions.h"
11
12

-- friends:
13
14
15
16
17
import HsDecls
import HsPat
import HsLit
import HsTypes
import HsBinds
18
19

-- others:
20
21
22
import Var
import Name
import BasicTypes
23
import DataCon
24
import SrcLoc
Ian Lynagh's avatar
Ian Lynagh committed
25
import Outputable
26
import FastString
27
28
\end{code}

29

30
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
31
%*                                                                      *
32
\subsection{Expressions proper}
Ian Lynagh's avatar
Ian Lynagh committed
33
%*                                                                      *
34
35
36
%************************************************************************

\begin{code}
37
38
-- * Expressions proper

39
40
type LHsExpr id = Located (HsExpr id)

41
-------------------------
42
43
-- | PostTcExpr is an evidence expression attached to the syntax tree by the
-- type checker (c.f. postTcType).
44
type PostTcExpr  = HsExpr Id
45
46
-- | We use a PostTcTable where there are a bunch of pieces of evidence, more
-- than is convenient to keep individually.
47
48
49
type PostTcTable = [(Name, Id)]

noPostTcExpr :: PostTcExpr
Ian Lynagh's avatar
Ian Lynagh committed
50
noPostTcExpr = HsLit (HsString (fsLit "noPostTcExpr"))
51
52
53
54
55

noPostTcTable :: PostTcTable
noPostTcTable = []

-------------------------
56
-- | SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier,
Ian Lynagh's avatar
Ian Lynagh committed
57
-- by the renamer.  It's used for rebindable syntax.
58
59
60
61
--
-- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for
--      @(>>=)@, and then instantiated by the type checker with its type args
--      tec
62
63
64

type SyntaxExpr id = HsExpr id

Ian Lynagh's avatar
Ian Lynagh committed
65
66
noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after,
                              -- (if the syntax slot makes no sense)
Ian Lynagh's avatar
Ian Lynagh committed
67
noSyntaxExpr = HsLit (HsString (fsLit "noSyntaxExpr"))
68
69
70


type SyntaxTable id = [(Name, SyntaxExpr id)]
71
72
73
-- ^ Currently used only for 'CmdTop' (sigh)
--
-- * Before the renamer, this list is 'noSyntaxTable'
74
--
75
-- * After the renamer, it takes the form @[(std_name, HsVar actual_name)]@
76
77
--   For example, for the 'return' op of a monad
--
78
79
80
81
82
83
84
--    * normal case:            @(GHC.Base.return, HsVar GHC.Base.return)@
--
--    * with rebindable syntax: @(GHC.Base.return, return_22)@
--              where @return_22@ is whatever @return@ is in scope
--
-- * After the type checker, it takes the form @[(std_name, <expression>)]@
--      where @<expression>@ is the evidence for the method
85
86
87
88
89
90

noSyntaxTable :: SyntaxTable id
noSyntaxTable = []


-------------------------
91
-- | A Haskell expression.
92
data HsExpr id
93
94
95
  = HsVar     id                        -- ^ variable
  | HsIPVar   (IPName id)               -- ^ implicit parameter
  | HsOverLit (HsOverLit id)            -- ^ Overloaded literals
96

97
  | HsLit     HsLit                     -- ^ Simple (non-overloaded) literals
98

Ian Lynagh's avatar
Ian Lynagh committed
99
  | HsLam     (MatchGroup id)           -- Currently always a single match
100

Ian Lynagh's avatar
Ian Lynagh committed
101
  | HsApp     (LHsExpr id) (LHsExpr id) -- Application
102

103
  -- Operator applications:
104
105
  -- NB Bracketed ops such as (+) come out as Vars.

106
107
108
  -- NB We need an expr for the operator in an OpApp/Section since
  -- the typechecker may need to apply the operator to a few types.

Ian Lynagh's avatar
Ian Lynagh committed
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
  | OpApp       (LHsExpr id)    -- left operand
                (LHsExpr id)    -- operator
                Fixity          -- Renamer adds fixity; bottom until then
                (LHsExpr id)    -- right operand

  | NegApp      (LHsExpr id)    -- negated expr
                (SyntaxExpr id) -- Name of 'negate'

  | HsPar       (LHsExpr id)    -- parenthesised expr

  | SectionL    (LHsExpr id)    -- operand
                (LHsExpr id)    -- operator
  | SectionR    (LHsExpr id)    -- operator
                (LHsExpr id)    -- operand

  | HsCase      (LHsExpr id)
                (MatchGroup id)

  | HsIf        (LHsExpr id)    --  predicate
                (LHsExpr id)    --  then part
                (LHsExpr id)    --  else part

  | HsLet       (HsLocalBinds id) -- let(rec)
                (LHsExpr  id)

  | HsDo        (HsStmtContext Name) -- The parameterisation is unimportant
                                     -- because in this context we never use
                                     -- the PatGuard or ParStmt variant
                [LStmt id]           -- "do":one or more stmts
                (LHsExpr id)         -- The body; the last expression in the
                                     -- 'do' of [ body | ... ] in a list comp
                PostTcType           -- Type of the whole expression

  | ExplicitList                -- syntactic list
                PostTcType      -- Gives type of components of list
                [LHsExpr id]

  | ExplicitPArr                -- syntactic parallel array: [:e1, ..., en:]
                PostTcType      -- type of elements of the parallel array
                [LHsExpr id]

  | ExplicitTuple               -- tuple
                [LHsExpr id]
                                -- NB: Unit is ExplicitTuple []
                                -- for tuples, we can get the types
                                -- direct from the components
                Boxity


  -- Record construction
  | RecordCon   (Located id)       -- The constructor.  After type checking
                                   -- it's the dataConWrapId of the constructor
                PostTcExpr         -- Data con Id applied to type args
                (HsRecordBinds id)

  -- Record update
  | RecordUpd   (LHsExpr id)
                (HsRecordBinds id)
167
168
--		(HsMatchGroup Id)  -- Filled in by the type checker to be 
--				   -- a match that does the job
Ian Lynagh's avatar
Ian Lynagh committed
169
                [DataCon]          -- Filled in by the type checker to the
Thomas Schilling's avatar
Thomas Schilling committed
170
                                   -- _non-empty_ list of DataCons that have
Ian Lynagh's avatar
Ian Lynagh committed
171
172
173
174
175
176
177
                                   -- all the upd'd fields
                [PostTcType]       -- Argument types of *input* record type
                [PostTcType]       --              and  *output* record type
  -- For a type family, the arg types are of the *instance* tycon,
  -- not the family tycon

  | ExprWithTySig                       -- e :: type
178
                (LHsExpr id)
Ian Lynagh's avatar
Ian Lynagh committed
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
                (LHsType id)

  | ExprWithTySigOut                    -- TRANSLATION
                (LHsExpr id)
                (LHsType Name)          -- Retain the signature for
                                        -- round-tripping purposes

  | ArithSeq                            -- arithmetic sequence
                PostTcExpr
                (ArithSeqInfo id)

  | PArrSeq                             -- arith. sequence for parallel array
                PostTcExpr              -- [:e1..e2:] or [:e1, e2..e3:]
                (ArithSeqInfo id)

  | HsSCC       FastString              -- "set cost centre" SCC pragma
                (LHsExpr id)            -- expr whose cost is to be measured

  | HsCoreAnn   FastString              -- hdaume: core annotation
                (LHsExpr id)

200
  -----------------------------------------------------------
201
  -- MetaHaskell Extensions
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
202

203
  | HsBracket    (HsBracket id)
204

Ian Lynagh's avatar
Ian Lynagh committed
205
206
207
  | HsBracketOut (HsBracket Name)       -- Output of the type checker is
                                        -- the *original*
                 [PendingSplice]        -- renamed expression, plus
Thomas Schilling's avatar
Thomas Schilling committed
208
                                        -- _typechecked_ splices to be
Ian Lynagh's avatar
Ian Lynagh committed
209
                                        -- pasted back in by the desugarer
210

Ian Lynagh's avatar
Ian Lynagh committed
211
  | HsSpliceE (HsSplice id)
212

213
214
215
  | HsQuasiQuoteE (HsQuasiQuote id)
	-- See Note [Quasi-quote overview] in TcSplice

216
217
218
  -----------------------------------------------------------
  -- Arrow notation extension

Ian Lynagh's avatar
Ian Lynagh committed
219
220
221
  | HsProc      (LPat id)               -- arrow abstraction, proc
                (LHsCmdTop id)          -- body of the abstraction
                                        -- always has an empty stack
222
223
224
225

  ---------------------------------------
  -- The following are commands, not expressions proper

Ian Lynagh's avatar
Ian Lynagh committed
226
227
228
229
230
231
232
233
  | HsArrApp            -- Arrow tail, or arrow application (f -< arg)
        (LHsExpr id)    -- arrow expression, f
        (LHsExpr id)    -- input expression, arg
        PostTcType      -- type of the arrow expressions f,
                        -- of the form a t t', where arg :: t
        HsArrAppType    -- higher-order (-<<) or first-order (-<)
        Bool            -- True => right-to-left (f -< arg)
                        -- False => left-to-right (arg >- f)
234

Ian Lynagh's avatar
Ian Lynagh committed
235
236
237
238
239
240
241
  | HsArrForm           -- Command formation,  (| e cmd1 .. cmdn |)
        (LHsExpr id)    -- the operator
                        -- after type-checking, a type abstraction to be
                        -- applied to the type of the local environment tuple
        (Maybe Fixity)  -- fixity (filled in by the renamer), for forms that
                        -- were converted from OpApp's by the renamer
        [LHsCmdTop id]  -- argument commands
242

243

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
244
245
246
  ---------------------------------------
  -- Haskell program coverage (Hpc) Support

Ian Lynagh's avatar
Ian Lynagh committed
247
248
  | HsTick
     Int                                -- module-local tick number
249
     [id]                               -- variables in scope
Ian Lynagh's avatar
Ian Lynagh committed
250
     (LHsExpr id)                       -- sub-expression
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
251
252

  | HsBinTick
Ian Lynagh's avatar
Ian Lynagh committed
253
254
255
     Int                                -- module-local tick number for True
     Int                                -- module-local tick number for False
     (LHsExpr id)                       -- sub-expression
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
256

Ian Lynagh's avatar
Ian Lynagh committed
257
258
259
  | HsTickPragma                        -- A pragma introduced tick
     (FastString,(Int,Int),(Int,Int))   -- external span for this tick
     (LHsExpr id)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
260
261
262
263

  ---------------------------------------
  -- These constructors only appear temporarily in the parser.
  -- The renamer translates them into the Right Thing.
264

Ian Lynagh's avatar
Ian Lynagh committed
265
  | EWildPat                 -- wildcard
266

Ian Lynagh's avatar
Ian Lynagh committed
267
268
  | EAsPat      (Located id) -- as pattern
                (LHsExpr id)
269

Ian Lynagh's avatar
Ian Lynagh committed
270
271
  | EViewPat    (LHsExpr id) -- view pattern
                (LHsExpr id)
272

Ian Lynagh's avatar
Ian Lynagh committed
273
  | ELazyPat    (LHsExpr id) -- ~ pattern
274

Ian Lynagh's avatar
Ian Lynagh committed
275
  | HsType      (LHsType id) -- Explicit type argument; e.g  f {| Int |} x y
276

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
277
278
  ---------------------------------------
  -- Finally, HsWrap appears only in typechecker output
279

Ian Lynagh's avatar
Ian Lynagh committed
280
281
  |  HsWrap     HsWrapper    -- TRANSLATION
                (HsExpr id)
282

Ian Lynagh's avatar
Ian Lynagh committed
283
284
type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be
                                        -- pasted back in by the desugarer
285
286
287
288
289
290
291
292
293
\end{code}

A @Dictionary@, unless of length 0 or 1, becomes a tuple.  A
@ClassDictLam dictvars methods expr@ is, therefore:
\begin{verbatim}
\ x -> case x of ( dictvars-and-methods-tuple ) -> expr
\end{verbatim}

\begin{code}
294
instance OutputableBndr id => Outputable (HsExpr id) where
295
    ppr expr = pprExpr expr
296
297
298
\end{code}

\begin{code}
299
-----------------------
Ian Lynagh's avatar
Ian Lynagh committed
300
-- pprExpr, pprLExpr, pprBinds call pprDeeper;
301
302
-- the underscore versions do not
pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc
303
304
305
pprLExpr (L _ e) = pprExpr e

pprExpr :: OutputableBndr id => HsExpr id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
306
307
308
309
310
311
312
313
314
315
316
317
pprExpr e | isAtomicHsExpr e || isQuietHsExpr e =            ppr_expr e
          | otherwise                           = pprDeeper (ppr_expr e)

isQuietHsExpr :: HsExpr id -> Bool
-- Parentheses do display something, but it gives little info and
-- if we go deeper when we go inside them then we get ugly things
-- like (...)
isQuietHsExpr (HsPar _) = True
-- applications don't display anything themselves
isQuietHsExpr (HsApp _ _) = True
isQuietHsExpr (OpApp _ _ _ _) = True
isQuietHsExpr _ = False
318

Ian Lynagh's avatar
Ian Lynagh committed
319
320
pprBinds :: (OutputableBndr idL, OutputableBndr idR)
         => HsLocalBindsLR idL idR -> SDoc
321
pprBinds b = pprDeeper (ppr b)
322

323
-----------------------
324
325
ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
326

327
ppr_expr :: OutputableBndr id => HsExpr id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
328
ppr_expr (HsVar v)       = pprHsVar v
329
ppr_expr (HsIPVar v)     = ppr v
330
331
ppr_expr (HsLit lit)     = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
Ian Lynagh's avatar
Ian Lynagh committed
332
ppr_expr (HsPar e)       = parens (ppr_lexpr e)
333
334

ppr_expr (HsCoreAnn s e)
Ian Lynagh's avatar
Ian Lynagh committed
335
  = vcat [ptext (sLit "HsCoreAnn") <+> ftext s, ppr_lexpr e]
336

337
338
ppr_expr (HsApp e1 e2)
  = let (fun, args) = collect_args e1 [e2] in
339
    hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))
340
  where
341
342
    collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
    collect_args fun args = (fun, args)
343

Ian Lynagh's avatar
Ian Lynagh committed
344
ppr_expr (OpApp e1 op _ e2)
345
  = case unLoc op of
346
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
347
      _       -> pp_prefixly
348
  where
Ian Lynagh's avatar
Ian Lynagh committed
349
    pp_e1 = pprDebugParendExpr e1   -- In debug mode, add parens
350
    pp_e2 = pprDebugParendExpr e2   -- to make precedence clear
351
352

    pp_prefixly
353
      = hang (ppr op) 2 (sep [pp_e1, pp_e2])
354
355

    pp_infixly v
356
      = sep [nest 2 pp_e1, pprHsInfix v, nest 2 pp_e2]
357

358
ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
359

360
ppr_expr (SectionL expr op)
361
  = case unLoc op of
362
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
363
      _       -> pp_prefixly
364
  where
365
    pp_expr = pprDebugParendExpr expr
366

367
    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
Ian Lynagh's avatar
Ian Lynagh committed
368
                       4 (hsep [pp_expr, ptext (sLit "x_ )")])
369
    pp_infixly v = (sep [pp_expr, pprHsInfix v])
370

371
ppr_expr (SectionR op expr)
372
  = case unLoc op of
373
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
374
      _       -> pp_prefixly
375
  where
376
    pp_expr = pprDebugParendExpr expr
377

Ian Lynagh's avatar
Ian Lynagh committed
378
    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")])
Ian Lynagh's avatar
Ian Lynagh committed
379
                       4 ((<>) pp_expr rparen)
380
    pp_infixly v
381
      = (sep [pprHsInfix v, pp_expr])
382

383
384
385
386
--avoid using PatternSignatures for stage1 code portability
ppr_expr exprType@(HsLam matches)
  = pprMatches (LambdaExpr `asTypeOf` idType exprType) matches
 where idType :: HsExpr id -> HsMatchContext id; idType = undefined
387

388
ppr_expr exprType@(HsCase expr matches)
389
390
  = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")],
          nest 2 (pprMatches (CaseAlt `asTypeOf` idType exprType) matches <+> char '}') ]
391
 where idType :: HsExpr id -> HsMatchContext id; idType = undefined
392

393
ppr_expr (HsIf e1 e2 e3)
Ian Lynagh's avatar
Ian Lynagh committed
394
  = sep [hsep [ptext (sLit "if"), nest 2 (ppr e1), ptext (sLit "then")],
Ian Lynagh's avatar
Ian Lynagh committed
395
         nest 4 (ppr e2),
Ian Lynagh's avatar
Ian Lynagh committed
396
         ptext (sLit "else"),
Ian Lynagh's avatar
Ian Lynagh committed
397
         nest 4 (ppr e3)]
398
399

-- special case: let ... in let ...
400
ppr_expr (HsLet binds expr@(L _ (HsLet _ _)))
Ian Lynagh's avatar
Ian Lynagh committed
401
  = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]),
Ian Lynagh's avatar
Ian Lynagh committed
402
         ppr_lexpr expr]
403

404
ppr_expr (HsLet binds expr)
Ian Lynagh's avatar
Ian Lynagh committed
405
406
  = sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
         hang (ptext (sLit "in"))  2 (ppr expr)]
407

408
ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body
409

410
ppr_expr (ExplicitList _ exprs)
411
  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
412

chak's avatar
chak committed
413
ppr_expr (ExplicitPArr _ exprs)
414
  = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
chak's avatar
chak committed
415

416
ppr_expr (ExplicitTuple exprs boxity)
417
  = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs)))
418

Ian Lynagh's avatar
Ian Lynagh committed
419
ppr_expr (RecordCon con_id _ rbinds)
420
  = hang (ppr con_id) 2 (ppr rbinds)
421

422
ppr_expr (RecordUpd aexp rbinds _ _ _)
423
  = hang (pprParendExpr aexp) 2 (ppr rbinds)
424
425

ppr_expr (ExprWithTySig expr sig)
426
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
Ian Lynagh's avatar
Ian Lynagh committed
427
         4 (ppr sig)
428
429
ppr_expr (ExprWithTySigOut expr sig)
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
Ian Lynagh's avatar
Ian Lynagh committed
430
         4 (ppr sig)
431

Ian Lynagh's avatar
Ian Lynagh committed
432
433
ppr_expr (ArithSeq _ info) = brackets (ppr info)
ppr_expr (PArrSeq  _ info) = pa_brackets (ppr info)
chak's avatar
chak committed
434

Ian Lynagh's avatar
Ian Lynagh committed
435
436
437
ppr_expr EWildPat       = char '_'
ppr_expr (ELazyPat e)   = char '~' <> pprParendExpr e
ppr_expr (EAsPat v e)   = ppr v <> char '@' <> pprParendExpr e
Ian Lynagh's avatar
Ian Lynagh committed
438
ppr_expr (EViewPat p e) = ppr p <+> ptext (sLit "->") <+> ppr e
439
440

ppr_expr (HsSCC lbl expr)
Ian Lynagh's avatar
Ian Lynagh committed
441
  = sep [ ptext (sLit "_scc_") <+> doubleQuotes (ftext lbl),
Ian Lynagh's avatar
Ian Lynagh committed
442
          pprParendExpr expr ]
443

444
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
Ian Lynagh's avatar
Ian Lynagh committed
445
ppr_expr (HsType id)      = ppr id
chak's avatar
chak committed
446

447
448
ppr_expr (HsSpliceE s)       = pprSplice s
ppr_expr (HsBracket b)       = pprHsBracket b
Ian Lynagh's avatar
Ian Lynagh committed
449
ppr_expr (HsBracketOut e []) = ppr e
Ian Lynagh's avatar
Ian Lynagh committed
450
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending") <+> ppr ps
451
ppr_expr (HsQuasiQuoteE qq)  = ppr qq
452

453
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
Ian Lynagh's avatar
Ian Lynagh committed
454
  = hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd]
455

456
ppr_expr (HsTick tickId vars exp)
Ian Lynagh's avatar
Ian Lynagh committed
457
  = hcat [ptext (sLit "tick<"),
Ian Lynagh's avatar
Ian Lynagh committed
458
          ppr tickId,
Ian Lynagh's avatar
Ian Lynagh committed
459
          ptext (sLit ">("),
Ian Lynagh's avatar
Ian Lynagh committed
460
461
          hsep (map pprHsVar vars),
          ppr exp,
Ian Lynagh's avatar
Ian Lynagh committed
462
          ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
463
ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
Ian Lynagh's avatar
Ian Lynagh committed
464
  = hcat [ptext (sLit "bintick<"),
Ian Lynagh's avatar
Ian Lynagh committed
465
          ppr tickIdTrue,
Ian Lynagh's avatar
Ian Lynagh committed
466
          ptext (sLit ","),
Ian Lynagh's avatar
Ian Lynagh committed
467
          ppr tickIdFalse,
Ian Lynagh's avatar
Ian Lynagh committed
468
469
          ptext (sLit ">("),
          ppr exp,ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
470
ppr_expr (HsTickPragma externalSrcLoc exp)
Ian Lynagh's avatar
Ian Lynagh committed
471
  = hcat [ptext (sLit "tickpragma<"),
Ian Lynagh's avatar
Ian Lynagh committed
472
          ppr externalSrcLoc,
Ian Lynagh's avatar
Ian Lynagh committed
473
          ptext (sLit ">("),
Ian Lynagh's avatar
Ian Lynagh committed
474
          ppr exp,
Ian Lynagh's avatar
Ian Lynagh committed
475
          ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
476

477
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
Ian Lynagh's avatar
Ian Lynagh committed
478
  = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg]
479
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
Ian Lynagh's avatar
Ian Lynagh committed
480
  = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow]
481
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
Ian Lynagh's avatar
Ian Lynagh committed
482
  = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg]
483
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
Ian Lynagh's avatar
Ian Lynagh committed
484
  = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
485

486
ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
487
  = sep [pprCmdArg (unLoc arg1), hsep [pprHsInfix v, pprCmdArg (unLoc arg2)]]
488
ppr_expr (HsArrForm op _ args)
Ian Lynagh's avatar
Ian Lynagh committed
489
490
  = hang (ptext (sLit "(|") <> ppr_lexpr op)
         4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
491
492

pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
493
494
495
496
pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
  = ppr_lexpr cmd
pprCmdArg (HsCmdTop cmd _ _ _)
  = parens (ppr_lexpr cmd)
497

Ian Lynagh's avatar
Ian Lynagh committed
498
499
500
instance OutputableBndr id => Outputable (HsCmdTop id) where
    ppr = pprCmdArg

chak's avatar
chak committed
501
502
-- add parallel array brackets around a document
--
503
pa_brackets :: SDoc -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
504
pa_brackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
505
506
\end{code}

507
508
509
510
511
512
513
514
515
516
HsSyn records exactly where the user put parens, with HsPar.
So generally speaking we print without adding any parens.
However, some code is internally generated, and in some places
parens are absolutely required; so for these places we use
pprParendExpr (but don't print double parens of course).

For operator applications we don't add parens, because the oprerator
fixities should do the job, except in debug mode (-dppr-debug) so we
can see the structure of the parse tree.

517
\begin{code}
518
519
520
521
pprDebugParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
pprDebugParendExpr expr
  = getPprStyle (\sty ->
    if debugStyle sty then pprParendExpr expr
Ian Lynagh's avatar
Ian Lynagh committed
522
523
                      else pprLExpr      expr)

524
pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
525
pprParendExpr expr
526
  = let
Ian Lynagh's avatar
Ian Lynagh committed
527
528
529
        pp_as_was = pprLExpr expr
        -- Using pprLExpr makes sure that we go 'deeper'
        -- I think that is usually (always?) right
530
    in
531
    case unLoc expr of
Ian Lynagh's avatar
Ian Lynagh committed
532
533
534
535
      HsLit _              -> pp_as_was
      HsOverLit _          -> pp_as_was
      HsVar _              -> pp_as_was
      HsIPVar _            -> pp_as_was
536
537
      ExplicitList _ _     -> pp_as_was
      ExplicitPArr _ _     -> pp_as_was
Ian Lynagh's avatar
Ian Lynagh committed
538
539
540
541
      ExplicitTuple _ _    -> pp_as_was
      HsPar _              -> pp_as_was
      HsBracket _          -> pp_as_was
      HsBracketOut _ []    -> pp_as_was
542
543
      HsDo sc _ _ _
       | isListCompExpr sc -> pp_as_was
Ian Lynagh's avatar
Ian Lynagh committed
544
      _                    -> parens pp_as_was
545

Ian Lynagh's avatar
Ian Lynagh committed
546
isAtomicHsExpr :: HsExpr id -> Bool -- A single token
547
548
549
550
551
552
isAtomicHsExpr (HsVar {})     = True
isAtomicHsExpr (HsLit {})     = True
isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {})   = True
isAtomicHsExpr (HsWrap _ e)   = isAtomicHsExpr e
isAtomicHsExpr (HsPar e)      = isAtomicHsExpr (unLoc e)
Ian Lynagh's avatar
Ian Lynagh committed
553
isAtomicHsExpr _              = False
554
555
\end{code}

556
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
557
%*                                                                      *
558
\subsection{Commands (in arrow abstractions)}
Ian Lynagh's avatar
Ian Lynagh committed
559
%*                                                                      *
560
561
562
563
564
565
566
%************************************************************************

We re-use HsExpr to represent these.

\begin{code}
type HsCmd id = HsExpr id

567
568
type LHsCmd id = LHsExpr id

569
570
571
572
573
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
\end{code}

The legal constructors for commands are:

Ian Lynagh's avatar
Ian Lynagh committed
574
  = HsArrApp ...                -- as above
575

Ian Lynagh's avatar
Ian Lynagh committed
576
  | HsArrForm ...               -- as above
577

Ian Lynagh's avatar
Ian Lynagh committed
578
579
  | HsApp       (HsCmd id)
                (HsExpr id)
ross's avatar
ross committed
580

Ian Lynagh's avatar
Ian Lynagh committed
581
  | HsLam       (Match  id)     -- kappa
582
583

  -- the renamer turns this one into HsArrForm
Ian Lynagh's avatar
Ian Lynagh committed
584
585
586
587
  | OpApp       (HsExpr id)     -- left operand
                (HsCmd id)      -- operator
                Fixity          -- Renamer adds fixity; bottom until then
                (HsCmd id)      -- right operand
588

Ian Lynagh's avatar
Ian Lynagh committed
589
  | HsPar       (HsCmd id)      -- parenthesised command
590

Ian Lynagh's avatar
Ian Lynagh committed
591
592
593
  | HsCase      (HsExpr id)
                [Match id]      -- bodies are HsCmd's
                SrcLoc
594

Ian Lynagh's avatar
Ian Lynagh committed
595
596
597
598
  | HsIf        (HsExpr id)     --  predicate
                (HsCmd id)      --  then part
                (HsCmd id)      --  else part
                SrcLoc
599

Ian Lynagh's avatar
Ian Lynagh committed
600
601
  | HsLet       (HsLocalBinds id)       -- let(rec)
                (HsCmd  id)
602

Ian Lynagh's avatar
Ian Lynagh committed
603
604
605
606
607
608
  | HsDo        (HsStmtContext Name)    -- The parameterisation is unimportant
                                        -- because in this context we never use
                                        -- the PatGuard or ParStmt variant
                [Stmt id]       -- HsExpr's are really HsCmd's
                PostTcType      -- Type of the whole expression
                SrcLoc
609
610
611
612
613
614

Top-level command, introducing a new arrow.
This may occur inside a proc (where the stack is empty) or as an
argument of a command-forming operator.

\begin{code}
615
616
type LHsCmdTop id = Located (HsCmdTop id)

617
data HsCmdTop id
Ian Lynagh's avatar
Ian Lynagh committed
618
619
620
621
622
  = HsCmdTop (LHsCmd id)
             [PostTcType]     -- types of inputs on the command's stack
             PostTcType       -- return type of the command
             (SyntaxTable id) -- after type checking:
                              -- names used in the command's desugaring
623
624
\end{code}

625
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
626
%*                                                                      *
627
\subsection{Record binds}
Ian Lynagh's avatar
Ian Lynagh committed
628
%*                                                                      *
629
630
631
%************************************************************************

\begin{code}
632
type HsRecordBinds id = HsRecFields id (LHsExpr id)
633
634
\end{code}

635
636


637
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
638
%*                                                                      *
639
\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
Ian Lynagh's avatar
Ian Lynagh committed
640
%*                                                                      *
641
642
%************************************************************************

643
644
645
646
647
648
649
650
651
652
653
654
655
656
@Match@es are sets of pattern bindings and right hand sides for
functions, patterns or case branches. For example, if a function @g@
is defined as:
\begin{verbatim}
g (x,y) = y
g ((x:ys),y) = y+1,
\end{verbatim}
then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.

It is always the case that each element of an @[Match]@ list has the
same number of @pats@s inside it.  This corresponds to saying that
a function defined by pattern matching must have the same number of
patterns in each equation.

657
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
658
659
660
661
662
663
data MatchGroup id
  = MatchGroup
        [LMatch id]     -- The alternatives
        PostTcType      -- The type is the type of the entire group
                        --      t1 -> ... -> tn -> tr
                        -- where there are n patterns
664

665
666
type LMatch id = Located (Match id)

667
data Match id
668
  = Match
Ian Lynagh's avatar
Ian Lynagh committed
669
670
671
672
        [LPat id]               -- The patterns
        (Maybe (LHsType id))    -- A type signature for the result of the match
                                -- Nothing after typechecking
        (GRHSs id)
673

674
675
676
isEmptyMatchGroup :: MatchGroup id -> Bool
isEmptyMatchGroup (MatchGroup ms _) = null ms

677
matchGroupArity :: MatchGroup id -> Arity
Ian Lynagh's avatar
Ian Lynagh committed
678
matchGroupArity (MatchGroup [] _)
679
  = panic "matchGroupArity"     -- Precondition: MatchGroup is non-empty
680
681
matchGroupArity (MatchGroup (match:matches) _)
  = ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
Ian Lynagh's avatar
Ian Lynagh committed
682
    -- Assertion just checks that all the matches have the same number of pats
683
684
685
686
    n_pats
  where
    n_pats = length (hsLMatchPats match)

687
688
689
hsLMatchPats :: LMatch id -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats

690
-- | GRHSs are used both for pattern bindings and for Matches
Ian Lynagh's avatar
Ian Lynagh committed
691
data GRHSs id
692
693
694
695
  = GRHSs {
      grhssGRHSs :: [LGRHS id],  -- ^ Guarded RHSs
      grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause
    }
696

697
type LGRHS id = Located (GRHS id)
698

699
-- | Guarded Right Hand Side.
Ian Lynagh's avatar
Ian Lynagh committed
700
701
data GRHS id = GRHS [LStmt id]   -- Guards
                    (LHsExpr id) -- Right hand side
702
\end{code}
703

704
We know the list must have at least one @Match@ in it.
705

706
\begin{code}
707
pprMatches :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> MatchGroup idR -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
708
709
pprMatches ctxt (MatchGroup matches _)
    = vcat (map (pprMatch ctxt) (map unLoc matches))
Ian Lynagh's avatar
Ian Lynagh committed
710
      -- Don't print the type; it's only a place-holder before typechecking
711
712

-- Exported to HsBinds, which can't see the defn of HsMatchContext
713
pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => idL -> Bool -> MatchGroup idR -> SDoc
714
pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
715
716

-- Exported to HsBinds, which can't see the defn of HsMatchContext
717
pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
Ian Lynagh's avatar
Ian Lynagh committed
718
           => LPat bndr -> GRHSs id -> SDoc
719
720
721
722
pprPatBind pat ty@(grhss)
 = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs `asTypeOf` idType ty) grhss)]
--avoid using PatternSignatures for stage1 code portability
 where idType :: GRHSs id -> HsMatchContext id; idType = undefined
723
724


725
pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc
726
pprMatch ctxt (Match pats maybe_ty grhss)
Ian Lynagh's avatar
Ian Lynagh committed
727
728
729
  = herald <+> sep [sep (map ppr other_pats),
                    ppr_maybe_ty,
                    nest 2 (pprGRHSs ctxt grhss)]
730
  where
Ian Lynagh's avatar
Ian Lynagh committed
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
    (herald, other_pats)
        = case ctxt of
            FunRhs fun is_infix
                | not is_infix -> (ppr fun, pats)
                        -- f x y z = e
                        -- Not pprBndr; the AbsBinds will
                        -- have printed the signature

                | null pats3 -> (pp_infix, [])
                        -- x &&& y = e

                | otherwise -> (parens pp_infix, pats3)
                        -- (x &&& y) z = e
                where
                  (pat1:pat2:pats3) = pats
                  pp_infix = ppr pat1 <+> ppr fun <+> ppr pat2

            LambdaExpr -> (char '\\', pats)
            _          -> (empty,     pats)
750

751
    ppr_maybe_ty = case maybe_ty of
Ian Lynagh's avatar
Ian Lynagh committed
752
753
                        Just ty -> dcolon <+> ppr ty
                        Nothing -> empty
754
755


Ian Lynagh's avatar
Ian Lynagh committed
756
757
pprGRHSs :: (OutputableBndr idL, OutputableBndr idR)
         => HsMatchContext idL -> GRHSs idR -> SDoc
758
pprGRHSs ctxt (GRHSs grhss binds)
Ian Lynagh's avatar
Ian Lynagh committed
759
760
761
  = vcat (map (pprGRHS ctxt . unLoc) grhss)
 $$ if isEmptyLocalBinds binds then empty
                               else text "where" $$ nest 4 (pprBinds binds)
762

Ian Lynagh's avatar
Ian Lynagh committed
763
764
pprGRHS :: (OutputableBndr idL, OutputableBndr idR)
        => HsMatchContext idL -> GRHS idR -> SDoc
765

766
pprGRHS ctxt (GRHS [] expr)
767
 =  pp_rhs ctxt expr
768

769
pprGRHS ctxt (GRHS guards expr)
770
 = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
771

Ian Lynagh's avatar
Ian Lynagh committed
772
pp_rhs :: OutputableBndr idR => HsMatchContext idL -> LHsExpr idR -> SDoc
773
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
774
\end{code}
775

776
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
777
%*                                                                      *
778
\subsection{Do stmts and list comprehensions}
Ian Lynagh's avatar
Ian Lynagh committed
779
%*                                                                      *
780
781
782
%************************************************************************

\begin{code}
783
784
785
786
type LStmt id = Located (StmtLR id id)
type LStmtLR idL idR = Located (StmtLR idL idR)

type Stmt id = StmtLR id id
787

Ian Lynagh's avatar
Ian Lynagh committed
788
789
790
791
792
793
794
795
data GroupByClause id
    = GroupByNothing (LHsExpr id) -- Using expression, i.e.
                                  -- "then group using f" ==> GroupByNothing f
    | GroupBySomething (Either (LHsExpr id) (SyntaxExpr id)) (LHsExpr id)
      -- "then group using f by e" ==> GroupBySomething (Left f) e
      -- "then group by e"         ==> GroupBySomething (Right _) e: in
      --                               this case the expression is filled
      --                               in by the renamer
796

797
798
-- The SyntaxExprs in here are used *only* for do-notation, which
-- has rebindable syntax.  Otherwise they are unused.
799
data StmtLR idL idR
Ian Lynagh's avatar
Ian Lynagh committed
800
801
802
803
804
805
  = BindStmt (LPat idL)
             (LHsExpr idR)
             (SyntaxExpr idR) -- The (>>=) operator
             (SyntaxExpr idR) -- The fail operator
             -- The fail operator is noSyntaxExpr
             -- if the pattern match can't fail
806

Ian Lynagh's avatar
Ian Lynagh committed
807
808
809
  | ExprStmt (LHsExpr idR)
             (SyntaxExpr idR) -- The (>>) operator
             PostTcType       -- Element type of the RHS (used for arrows)
810

Ian Lynagh's avatar
Ian Lynagh committed
811
  | LetStmt  (HsLocalBindsLR idL idR)
812

Ian Lynagh's avatar
Ian Lynagh committed
813
814
815
816
  -- ParStmts only occur in a list comprehension
  | ParStmt  [([LStmt idL], [idR])]
  -- After renaming, the ids are the binders bound by the stmts and used
  -- after them
817
818

  | TransformStmt ([LStmt idL], [idR]) (LHsExpr idR) (Maybe (LHsExpr idR))
Ian Lynagh's avatar
Ian Lynagh committed
819
820
821
822
  -- After renaming, the IDs are the binders occurring within this
  -- transform statement that are used after it
  -- "qs, then f by e" ==> TransformStmt (qs, binders) f (Just e)
  -- "qs, then f"      ==> TransformStmt (qs, binders) f Nothing
823
824

  | GroupStmt ([LStmt idL], [(idR, idR)]) (GroupByClause idR)
Ian Lynagh's avatar
Ian Lynagh committed
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
  -- After renaming, the IDs are the binders occurring within this
  -- transform statement that are used after it which are paired with
  -- the names which they group over in statements

  -- Recursive statement (see Note [RecStmt] below)
  | RecStmt  [LStmtLR idL idR]
             --- The next two fields are only valid after renaming
             [idR] -- The ids are a subset of the variables bound by the
                   -- stmts that are used in stmts that follow the RecStmt

             [idR] -- Ditto, but these variables are the "recursive" ones,
                   -- that are used before they are bound in the stmts of
                   -- the RecStmt. From a type-checking point of view,
                   -- these ones have to be monomorphic

             --- These fields are only valid after typechecking
             [PostTcExpr]       -- These expressions correspond 1-to-1 with
                                -- the "recursive" [id], and are the
                                -- expressions that should be returned by
                                -- the recursion.
                                -- They may not quite be the Ids themselves,
                                -- because the Id may be *polymorphic*, but
                                -- the returned thing has to be *monomorphic*.
             (DictBinds idR)    -- Method bindings of Ids bound by the
                                -- RecStmt, and used afterwards
850
851
\end{code}

852
ExprStmts are a bit tricky, because what they mean
853
depends on the context.  Consider the following contexts:
854

Ian Lynagh's avatar
Ian Lynagh committed
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
        A do expression of type (m res_ty)
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        * ExprStmt E any_ty:   do { ....; E; ... }
                E :: m any_ty
          Translation: E >> ...

        A list comprehensions of type [elt_ty]
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        * ExprStmt E Bool:   [ .. | .... E ]
                        [ .. | ..., E, ... ]
                        [ .. | .... | ..., E | ... ]
                E :: Bool
          Translation: if E then fail else ...

        A guard list, guarding a RHS of type rhs_ty
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        * ExprStmt E Bool:   f x | ..., E, ... = ...rhs...
                E :: Bool
          Translation: if E then fail else ...

chak's avatar
chak committed
875
Array comprehensions are handled like list comprehensions -=chak
876

877
878
879
Note [RecStmt]
~~~~~~~~~~~~~~
Example:
Ian Lynagh's avatar
Ian Lynagh committed
880
        HsDo [ BindStmt x ex
881

Ian Lynagh's avatar
Ian Lynagh committed
882
883
884
885
886
             , RecStmt [a::forall a. a -> a, b]
                       [a::Int -> Int,       c]
                       [ BindStmt b (return x)
                       , LetStmt a = ea
                       , BindStmt c ec ]
887

Ian Lynagh's avatar
Ian Lynagh committed
888
             , return (a b) ]
889

Ian Lynagh's avatar
Ian Lynagh committed
890
891
892
Here, the RecStmt binds a,b,c; but
  - Only a,b are used in the stmts *following* the RecStmt,
        This 'a' is *polymorphic'
893
  - Only a,c are used in the stmts *inside* the RecStmt
Ian Lynagh's avatar
Ian Lynagh committed
894
895
        *before* their bindings
        This 'a' is monomorphic
896
897
898
899
900

Nota Bene: the two a's have different types, even though they
have the same Name.


901
\begin{code}
902
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where
903
904
    ppr stmt = pprStmt stmt

905
pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
906
907
pprStmt (BindStmt pat expr _ _)   = hsep [ppr pat, ptext (sLit "<-"), ppr expr]
pprStmt (LetStmt binds)           = hsep [ptext (sLit "let"), pprBinds binds]
Ian Lynagh's avatar
Ian Lynagh committed
908
909
pprStmt (ExprStmt expr _ _)       = ppr expr
pprStmt (ParStmt stmtss)          = hsep (map doStmts stmtss)
Ian Lynagh's avatar
Ian Lynagh committed
910
  where doStmts stmts = ptext (sLit "| ") <> ppr stmts
Ian Lynagh's avatar
Ian Lynagh committed
911
pprStmt (TransformStmt (stmts, _) usingExpr maybeByExpr)
Ian Lynagh's avatar
Ian Lynagh committed
912
    = (hsep [stmtsDoc, ptext (sLit "then"), ppr usingExpr, byExprDoc])
913
  where stmtsDoc = interpp'SP stmts
Ian Lynagh's avatar
Ian Lynagh committed
914
915
        byExprDoc = maybe empty (\byExpr -> hsep [ptext (sLit "by"), ppr byExpr]) maybeByExpr
pprStmt (GroupStmt (stmts, _) groupByClause) = (hsep [stmtsDoc, ptext (sLit "then group"), pprGroupByClause groupByClause])
916
  where stmtsDoc = interpp'SP stmts
Ian Lynagh's avatar
Ian Lynagh committed
917
pprStmt (RecStmt segment _ _ _ _) = ptext (sLit "rec") <+> braces (vcat (map ppr segment))
918

919
pprGroupByClause :: (OutputableBndr id) => GroupByClause id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
920
921
922
pprGroupByClause (GroupByNothing usingExpr) = hsep [ptext (sLit "using"), ppr usingExpr]
pprGroupByClause (GroupBySomething eitherUsingExpr byExpr) = hsep [ptext (sLit "by"), ppr byExpr, usingExprDoc]
  where usingExprDoc = either (\usingExpr -> hsep [ptext (sLit "using"), ppr usingExpr]) (const empty) eitherUsingExpr
923

924
pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
925
926
pprDo DoExpr      stmts body = ptext (sLit "do")  <+> pprDeeperList vcat (map ppr stmts ++ [ppr body])
pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body])
927
928
pprDo ListComp    stmts body = pprComp brackets    stmts body
pprDo PArrComp    stmts body = pprComp pa_brackets stmts body
Ian Lynagh's avatar
Ian Lynagh committed
929
pprDo _           _     _    = panic "pprDo" -- PatGuard, ParStmtCxt
930
931
932

pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc
pprComp brack quals body
933
  = brack $
Ian Lynagh's avatar
Ian Lynagh committed
934
935
        hang (ppr body <+> char '|')
             4 (interpp'SP quals)
936
937
\end{code}

938
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
939
940
941
%*                                                                      *
                Template Haskell quotation brackets
%*                                                                      *
942
943
944
%************************************************************************

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
945
946
947
948
data HsSplice id  = HsSplice            --  $z  or $(f 4)
                        id              -- The id is just a unique name to
                        (LHsExpr id)    -- identify this splice point

949
950
951
952
instance OutputableBndr id => Outputable (HsSplice id) where
  ppr = pprSplice

pprSplice :: OutputableBndr id => HsSplice id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
953
954
pprSplice (HsSplice n e)
    = char '$' <> ifPprDebug (brackets (ppr n)) <> pprParendExpr e
955
956


Ian Lynagh's avatar
Ian Lynagh committed
957
958
959
960
961
data HsBracket id = ExpBr (LHsExpr id)          -- [|  expr  |]
                  | PatBr (LPat id)             -- [p| pat   |]
                  | DecBr (HsGroup id)          -- [d| decls |]
                  | TypBr (LHsType id)          -- [t| type  |]
                  | VarBr id                    -- 'x, ''T
962
963
964
965
966

instance OutputableBndr id => Outputable (HsBracket id) where
  ppr = pprHsBracket


Ian Lynagh's avatar
Ian Lynagh committed
967
pprHsBracket :: OutputableBndr id => HsBracket id -> SDoc
968
969
pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
970
pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d)
971
pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
972
pprHsBracket (VarBr n) = char '\'' <> ppr n
Ian Lynagh's avatar
Ian Lynagh committed
973
974
975
976
-- Infelicity: can't show ' vs '', because
-- we can't ask n what its OccName is, because the
-- pretty-printer for HsExpr doesn't ask for NamedThings
-- But the pretty-printer for names will show the OccName class
977

Ian Lynagh's avatar
Ian Lynagh committed
978
thBrackets :: SDoc -> SDoc -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
979
thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
Ian Lynagh's avatar
Ian Lynagh committed
980
                             pp_body <+> ptext (sLit "|]")
981
982
\end{code}

983
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
984
%*                                                                      *
985
\subsection{Enumerations and list comprehensions}
Ian Lynagh's avatar
Ian Lynagh committed
986
%*                                                                      *
987
988
989
%************************************************************************

\begin{code}
990
data ArithSeqInfo id
Ian Lynagh's avatar
Ian Lynagh committed
991
992
993
994
995
996
997
998
  = From            (LHsExpr id)
  | FromThen        (LHsExpr id)
                    (LHsExpr id)
  | FromTo          (LHsExpr id)
                    (LHsExpr id)
  | FromThenTo      (LHsExpr id)
                    (LHsExpr id)
                    (LHsExpr id)
999
1000
1001
\end{code}

\begin{code}
1002
instance OutputableBndr id => Outputable (ArithSeqInfo id) where
Ian Lynagh's avatar
Ian Lynagh committed
1003
1004
1005
    ppr (From e1)             = hcat [ppr e1, pp_dotdot]
    ppr (FromThen e1 e2)      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
    ppr (FromTo e1 e3)        = hcat [ppr e1, pp_dotdot, ppr e3]
1006
1007
    ppr (FromThenTo e1 e2 e3)
      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]
1008

Ian Lynagh's avatar
Ian Lynagh committed
1009
pp_dotdot :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
1010
pp_dotdot = ptext (sLit " .. ")
1011
\end{code}
1012
1013
1014


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
1015
%*                                                                      *
1016
\subsection{HsMatchCtxt}
Ian Lynagh's avatar
Ian Lynagh committed
1017
%*                                                                      *
1018
1019
1020
%************************************************************************

\begin{code}