HsExpr.lhs 42.4 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
5
6

HsExpr: Abstract Haskell syntax: expressions
7
8
9
10

\begin{code}
module HsExpr where

11
#include "HsVersions.h"
12
13

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

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

30

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

\begin{code}
38
39
type LHsExpr id = Located (HsExpr id)

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

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

noPostTcTable :: PostTcTable
noPostTcTable = []

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

type SyntaxExpr id = HsExpr id

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


type SyntaxTable id = [(Name, SyntaxExpr id)]
Ian Lynagh's avatar
Ian Lynagh committed
69
-- *** Currently used only for CmdTop (sigh) ***
70
71
72
73
-- * Before the renamer, this list is noSyntaxTable
--
-- * After the renamer, it takes the form [(std_name, HsVar actual_name)]
--   For example, for the 'return' op of a monad
Ian Lynagh's avatar
Ian Lynagh committed
74
75
76
--      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
77
78
--
-- * After the type checker, it takes the form [(std_name, <expression>)]
Ian Lynagh's avatar
Ian Lynagh committed
79
--      where <expression> is the evidence for the method
80
81
82
83
84
85

noSyntaxTable :: SyntaxTable id
noSyntaxTable = []


-------------------------
86
data HsExpr id
Ian Lynagh's avatar
Ian Lynagh committed
87
88
89
  = HsVar     id                        -- variable
  | HsIPVar   (IPName id)               -- implicit parameter
  | HsOverLit (HsOverLit id)            -- Overloaded literals
90

Ian Lynagh's avatar
Ian Lynagh committed
91
  | HsLit     HsLit                     -- Simple (non-overloaded) literals
92

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

Ian Lynagh's avatar
Ian Lynagh committed
95
  | HsApp     (LHsExpr id) (LHsExpr id) -- Application
96

97
  -- Operator applications:
98
99
  -- NB Bracketed ops such as (+) come out as Vars.

100
101
102
  -- 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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
  | 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)
                [DataCon]          -- Filled in by the type checker to the
Thomas Schilling's avatar
Thomas Schilling committed
162
                                   -- _non-empty_ list of DataCons that have
Ian Lynagh's avatar
Ian Lynagh committed
163
164
165
166
167
168
169
                                   -- 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
170
                (LHsExpr id)
Ian Lynagh's avatar
Ian Lynagh committed
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
                (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)

192
  -----------------------------------------------------------
193
  -- MetaHaskell Extensions
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
194

195
  | HsBracket    (HsBracket id)
196

Ian Lynagh's avatar
Ian Lynagh committed
197
198
199
  | HsBracketOut (HsBracket Name)       -- Output of the type checker is
                                        -- the *original*
                 [PendingSplice]        -- renamed expression, plus
Thomas Schilling's avatar
Thomas Schilling committed
200
                                        -- _typechecked_ splices to be
Ian Lynagh's avatar
Ian Lynagh committed
201
                                        -- pasted back in by the desugarer
202

Ian Lynagh's avatar
Ian Lynagh committed
203
  | HsSpliceE (HsSplice id)
204

205
206
207
  | HsQuasiQuoteE (HsQuasiQuote id)
	-- See Note [Quasi-quote overview] in TcSplice

208
209
210
  -----------------------------------------------------------
  -- Arrow notation extension

Ian Lynagh's avatar
Ian Lynagh committed
211
212
213
  | HsProc      (LPat id)               -- arrow abstraction, proc
                (LHsCmdTop id)          -- body of the abstraction
                                        -- always has an empty stack
214
215
216
217

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

Ian Lynagh's avatar
Ian Lynagh committed
218
219
220
221
222
223
224
225
  | 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)
226

Ian Lynagh's avatar
Ian Lynagh committed
227
228
229
230
231
232
233
  | 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
234

235

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
236
237
238
  ---------------------------------------
  -- Haskell program coverage (Hpc) Support

Ian Lynagh's avatar
Ian Lynagh committed
239
240
  | HsTick
     Int                                -- module-local tick number
241
     [id]                               -- variables in scope
Ian Lynagh's avatar
Ian Lynagh committed
242
     (LHsExpr id)                       -- sub-expression
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
243
244

  | HsBinTick
Ian Lynagh's avatar
Ian Lynagh committed
245
246
247
     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
248

Ian Lynagh's avatar
Ian Lynagh committed
249
250
251
  | 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
252
253
254
255

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

Ian Lynagh's avatar
Ian Lynagh committed
257
  | EWildPat                 -- wildcard
258

Ian Lynagh's avatar
Ian Lynagh committed
259
260
  | EAsPat      (Located id) -- as pattern
                (LHsExpr id)
261

Ian Lynagh's avatar
Ian Lynagh committed
262
263
  | EViewPat    (LHsExpr id) -- view pattern
                (LHsExpr id)
264

Ian Lynagh's avatar
Ian Lynagh committed
265
  | ELazyPat    (LHsExpr id) -- ~ pattern
266

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

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
269
270
  ---------------------------------------
  -- Finally, HsWrap appears only in typechecker output
271

Ian Lynagh's avatar
Ian Lynagh committed
272
273
  |  HsWrap     HsWrapper    -- TRANSLATION
                (HsExpr id)
274

Ian Lynagh's avatar
Ian Lynagh committed
275
276
type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be
                                        -- pasted back in by the desugarer
277
278
279
280
281
282
283
284
285
\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}
286
instance OutputableBndr id => Outputable (HsExpr id) where
287
    ppr expr = pprExpr expr
288
289
290
\end{code}

\begin{code}
291
-----------------------
Ian Lynagh's avatar
Ian Lynagh committed
292
-- pprExpr, pprLExpr, pprBinds call pprDeeper;
293
294
-- the underscore versions do not
pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc
295
296
297
pprLExpr (L _ e) = pprExpr e

pprExpr :: OutputableBndr id => HsExpr id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
298
299
300
301
302
303
304
305
306
307
308
309
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
310

Ian Lynagh's avatar
Ian Lynagh committed
311
312
pprBinds :: (OutputableBndr idL, OutputableBndr idR)
         => HsLocalBindsLR idL idR -> SDoc
313
pprBinds b = pprDeeper (ppr b)
314

315
-----------------------
316
317
ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
318

319
ppr_expr :: OutputableBndr id => HsExpr id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
320
ppr_expr (HsVar v)       = pprHsVar v
321
ppr_expr (HsIPVar v)     = ppr v
322
323
ppr_expr (HsLit lit)     = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
Ian Lynagh's avatar
Ian Lynagh committed
324
ppr_expr (HsPar e)       = parens (ppr_lexpr e)
325
326

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

329
330
ppr_expr (HsApp e1 e2)
  = let (fun, args) = collect_args e1 [e2] in
331
    hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))
332
  where
333
334
    collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
    collect_args fun args = (fun, args)
335

Ian Lynagh's avatar
Ian Lynagh committed
336
ppr_expr (OpApp e1 op _ e2)
337
  = case unLoc op of
338
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
339
      _       -> pp_prefixly
340
  where
Ian Lynagh's avatar
Ian Lynagh committed
341
    pp_e1 = pprDebugParendExpr e1   -- In debug mode, add parens
342
    pp_e2 = pprDebugParendExpr e2   -- to make precedence clear
343
344

    pp_prefixly
345
      = hang (ppr op) 2 (sep [pp_e1, pp_e2])
346
347

    pp_infixly v
348
      = sep [nest 2 pp_e1, pprHsInfix v, nest 2 pp_e2]
349

350
ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
351

352
ppr_expr (SectionL expr op)
353
  = case unLoc op of
354
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
355
      _       -> pp_prefixly
356
  where
357
    pp_expr = pprDebugParendExpr expr
358

359
    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
Ian Lynagh's avatar
Ian Lynagh committed
360
                       4 (hsep [pp_expr, ptext (sLit "x_ )")])
361
    pp_infixly v = (sep [pp_expr, pprHsInfix v])
362

363
ppr_expr (SectionR op expr)
364
  = case unLoc op of
365
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
366
      _       -> pp_prefixly
367
  where
368
    pp_expr = pprDebugParendExpr expr
369

Ian Lynagh's avatar
Ian Lynagh committed
370
    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")])
Ian Lynagh's avatar
Ian Lynagh committed
371
                       4 ((<>) pp_expr rparen)
372
    pp_infixly v
373
      = (sep [pprHsInfix v, pp_expr])
374

375
376
377
378
--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
379

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

385
ppr_expr (HsIf e1 e2 e3)
Ian Lynagh's avatar
Ian Lynagh committed
386
  = sep [hsep [ptext (sLit "if"), nest 2 (ppr e1), ptext (sLit "then")],
Ian Lynagh's avatar
Ian Lynagh committed
387
         nest 4 (ppr e2),
Ian Lynagh's avatar
Ian Lynagh committed
388
         ptext (sLit "else"),
Ian Lynagh's avatar
Ian Lynagh committed
389
         nest 4 (ppr e3)]
390
391

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

396
ppr_expr (HsLet binds expr)
Ian Lynagh's avatar
Ian Lynagh committed
397
398
  = sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
         hang (ptext (sLit "in"))  2 (ppr expr)]
399

400
ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body
401

402
ppr_expr (ExplicitList _ exprs)
403
  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
404

chak's avatar
chak committed
405
ppr_expr (ExplicitPArr _ exprs)
406
  = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
chak's avatar
chak committed
407

408
ppr_expr (ExplicitTuple exprs boxity)
409
  = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs)))
410

Ian Lynagh's avatar
Ian Lynagh committed
411
ppr_expr (RecordCon con_id _ rbinds)
412
  = hang (ppr con_id) 2 (ppr rbinds)
413

414
ppr_expr (RecordUpd aexp rbinds _ _ _)
415
  = hang (pprParendExpr aexp) 2 (ppr rbinds)
416
417

ppr_expr (ExprWithTySig expr sig)
418
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
Ian Lynagh's avatar
Ian Lynagh committed
419
         4 (ppr sig)
420
421
ppr_expr (ExprWithTySigOut expr sig)
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
Ian Lynagh's avatar
Ian Lynagh committed
422
         4 (ppr sig)
423

Ian Lynagh's avatar
Ian Lynagh committed
424
425
ppr_expr (ArithSeq _ info) = brackets (ppr info)
ppr_expr (PArrSeq  _ info) = pa_brackets (ppr info)
chak's avatar
chak committed
426

Ian Lynagh's avatar
Ian Lynagh committed
427
428
429
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
430
ppr_expr (EViewPat p e) = ppr p <+> ptext (sLit "->") <+> ppr e
431
432

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

436
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
Ian Lynagh's avatar
Ian Lynagh committed
437
ppr_expr (HsType id)      = ppr id
chak's avatar
chak committed
438

439
440
ppr_expr (HsSpliceE s)       = pprSplice s
ppr_expr (HsBracket b)       = pprHsBracket b
Ian Lynagh's avatar
Ian Lynagh committed
441
ppr_expr (HsBracketOut e []) = ppr e
Ian Lynagh's avatar
Ian Lynagh committed
442
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending") <+> ppr ps
443
ppr_expr (HsQuasiQuoteE qq)  = ppr qq
444

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

448
ppr_expr (HsTick tickId vars exp)
Ian Lynagh's avatar
Ian Lynagh committed
449
  = hcat [ptext (sLit "tick<"),
Ian Lynagh's avatar
Ian Lynagh committed
450
          ppr tickId,
Ian Lynagh's avatar
Ian Lynagh committed
451
          ptext (sLit ">("),
Ian Lynagh's avatar
Ian Lynagh committed
452
453
          hsep (map pprHsVar vars),
          ppr exp,
Ian Lynagh's avatar
Ian Lynagh committed
454
          ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
455
ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
Ian Lynagh's avatar
Ian Lynagh committed
456
  = hcat [ptext (sLit "bintick<"),
Ian Lynagh's avatar
Ian Lynagh committed
457
          ppr tickIdTrue,
Ian Lynagh's avatar
Ian Lynagh committed
458
          ptext (sLit ","),
Ian Lynagh's avatar
Ian Lynagh committed
459
          ppr tickIdFalse,
Ian Lynagh's avatar
Ian Lynagh committed
460
461
          ptext (sLit ">("),
          ppr exp,ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
462
ppr_expr (HsTickPragma externalSrcLoc exp)
Ian Lynagh's avatar
Ian Lynagh committed
463
  = hcat [ptext (sLit "tickpragma<"),
Ian Lynagh's avatar
Ian Lynagh committed
464
          ppr externalSrcLoc,
Ian Lynagh's avatar
Ian Lynagh committed
465
          ptext (sLit ">("),
Ian Lynagh's avatar
Ian Lynagh committed
466
          ppr exp,
Ian Lynagh's avatar
Ian Lynagh committed
467
          ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
468

469
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
Ian Lynagh's avatar
Ian Lynagh committed
470
  = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg]
471
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
Ian Lynagh's avatar
Ian Lynagh committed
472
  = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow]
473
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
Ian Lynagh's avatar
Ian Lynagh committed
474
  = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg]
475
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
Ian Lynagh's avatar
Ian Lynagh committed
476
  = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
477

478
ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
479
  = sep [pprCmdArg (unLoc arg1), hsep [pprHsInfix v, pprCmdArg (unLoc arg2)]]
480
ppr_expr (HsArrForm op _ args)
Ian Lynagh's avatar
Ian Lynagh committed
481
482
  = hang (ptext (sLit "(|") <> ppr_lexpr op)
         4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
483
484

pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
485
486
487
488
pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
  = ppr_lexpr cmd
pprCmdArg (HsCmdTop cmd _ _ _)
  = parens (ppr_lexpr cmd)
489

Ian Lynagh's avatar
Ian Lynagh committed
490
491
492
instance OutputableBndr id => Outputable (HsCmdTop id) where
    ppr = pprCmdArg

chak's avatar
chak committed
493
494
-- add parallel array brackets around a document
--
495
pa_brackets :: SDoc -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
496
pa_brackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
497
498
\end{code}

499
500
501
502
503
504
505
506
507
508
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.

509
\begin{code}
510
511
512
513
pprDebugParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
pprDebugParendExpr expr
  = getPprStyle (\sty ->
    if debugStyle sty then pprParendExpr expr
Ian Lynagh's avatar
Ian Lynagh committed
514
515
                      else pprLExpr      expr)

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

Ian Lynagh's avatar
Ian Lynagh committed
538
isAtomicHsExpr :: HsExpr id -> Bool -- A single token
539
540
541
542
543
544
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
545
isAtomicHsExpr _              = False
546
547
\end{code}

548
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
549
%*                                                                      *
550
\subsection{Commands (in arrow abstractions)}
Ian Lynagh's avatar
Ian Lynagh committed
551
%*                                                                      *
552
553
554
555
556
557
558
%************************************************************************

We re-use HsExpr to represent these.

\begin{code}
type HsCmd id = HsExpr id

559
560
type LHsCmd id = LHsExpr id

561
562
563
564
565
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
\end{code}

The legal constructors for commands are:

Ian Lynagh's avatar
Ian Lynagh committed
566
  = HsArrApp ...                -- as above
567

Ian Lynagh's avatar
Ian Lynagh committed
568
  | HsArrForm ...               -- as above
569

Ian Lynagh's avatar
Ian Lynagh committed
570
571
  | HsApp       (HsCmd id)
                (HsExpr id)
ross's avatar
ross committed
572

Ian Lynagh's avatar
Ian Lynagh committed
573
  | HsLam       (Match  id)     -- kappa
574
575

  -- the renamer turns this one into HsArrForm
Ian Lynagh's avatar
Ian Lynagh committed
576
577
578
579
  | OpApp       (HsExpr id)     -- left operand
                (HsCmd id)      -- operator
                Fixity          -- Renamer adds fixity; bottom until then
                (HsCmd id)      -- right operand
580

Ian Lynagh's avatar
Ian Lynagh committed
581
  | HsPar       (HsCmd id)      -- parenthesised command
582

Ian Lynagh's avatar
Ian Lynagh committed
583
584
585
  | HsCase      (HsExpr id)
                [Match id]      -- bodies are HsCmd's
                SrcLoc
586

Ian Lynagh's avatar
Ian Lynagh committed
587
588
589
590
  | HsIf        (HsExpr id)     --  predicate
                (HsCmd id)      --  then part
                (HsCmd id)      --  else part
                SrcLoc
591

Ian Lynagh's avatar
Ian Lynagh committed
592
593
  | HsLet       (HsLocalBinds id)       -- let(rec)
                (HsCmd  id)
594

Ian Lynagh's avatar
Ian Lynagh committed
595
596
597
598
599
600
  | 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
601
602
603
604
605
606

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}
607
608
type LHsCmdTop id = Located (HsCmdTop id)

609
data HsCmdTop id
Ian Lynagh's avatar
Ian Lynagh committed
610
611
612
613
614
  = 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
615
616
\end{code}

617
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
618
%*                                                                      *
619
\subsection{Record binds}
Ian Lynagh's avatar
Ian Lynagh committed
620
%*                                                                      *
621
622
623
%************************************************************************

\begin{code}
624
type HsRecordBinds id = HsRecFields id (LHsExpr id)
625
626
\end{code}

627
628


629
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
630
%*                                                                      *
631
\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
Ian Lynagh's avatar
Ian Lynagh committed
632
%*                                                                      *
633
634
%************************************************************************

635
636
637
638
639
640
641
642
643
644
645
646
647
648
@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.

649
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
650
651
652
653
654
655
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
656

657
658
type LMatch id = Located (Match id)

659
data Match id
660
  = Match
Ian Lynagh's avatar
Ian Lynagh committed
661
662
663
664
        [LPat id]               -- The patterns
        (Maybe (LHsType id))    -- A type signature for the result of the match
                                -- Nothing after typechecking
        (GRHSs id)
665

666
667
668
isEmptyMatchGroup :: MatchGroup id -> Bool
isEmptyMatchGroup (MatchGroup ms _) = null ms

669
matchGroupArity :: MatchGroup id -> Arity
Ian Lynagh's avatar
Ian Lynagh committed
670
matchGroupArity (MatchGroup [] _)
671
  = panic "matchGroupArity"     -- Precondition: MatchGroup is non-empty
672
673
matchGroupArity (MatchGroup (match:matches) _)
  = ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
Ian Lynagh's avatar
Ian Lynagh committed
674
    -- Assertion just checks that all the matches have the same number of pats
675
676
677
678
    n_pats
  where
    n_pats = length (hsLMatchPats match)

679
680
681
hsLMatchPats :: LMatch id -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats

682
-- GRHSs are used both for pattern bindings and for Matches
Ian Lynagh's avatar
Ian Lynagh committed
683
684
685
data GRHSs id
  = GRHSs [LGRHS id]             -- Guarded RHSs
          (HsLocalBinds id)      -- The where clause
686

687
type LGRHS id = Located (GRHS id)
688

Ian Lynagh's avatar
Ian Lynagh committed
689
690
data GRHS id = GRHS [LStmt id]   -- Guards
                    (LHsExpr id) -- Right hand side
691
\end{code}
692

693
We know the list must have at least one @Match@ in it.
694

695
\begin{code}
696
pprMatches :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> MatchGroup idR -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
697
698
pprMatches ctxt (MatchGroup matches _)
    = vcat (map (pprMatch ctxt) (map unLoc matches))
Ian Lynagh's avatar
Ian Lynagh committed
699
      -- Don't print the type; it's only a place-holder before typechecking
700
701

-- Exported to HsBinds, which can't see the defn of HsMatchContext
702
pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => idL -> Bool -> MatchGroup idR -> SDoc
703
pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
704
705

-- Exported to HsBinds, which can't see the defn of HsMatchContext
706
pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
Ian Lynagh's avatar
Ian Lynagh committed
707
           => LPat bndr -> GRHSs id -> SDoc
708
709
710
711
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
712
713


714
pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc
715
pprMatch ctxt (Match pats maybe_ty grhss)
Ian Lynagh's avatar
Ian Lynagh committed
716
717
718
  = herald <+> sep [sep (map ppr other_pats),
                    ppr_maybe_ty,
                    nest 2 (pprGRHSs ctxt grhss)]
719
  where
Ian Lynagh's avatar
Ian Lynagh committed
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
    (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)
739

740
    ppr_maybe_ty = case maybe_ty of
Ian Lynagh's avatar
Ian Lynagh committed
741
742
                        Just ty -> dcolon <+> ppr ty
                        Nothing -> empty
743
744


Ian Lynagh's avatar
Ian Lynagh committed
745
746
pprGRHSs :: (OutputableBndr idL, OutputableBndr idR)
         => HsMatchContext idL -> GRHSs idR -> SDoc
747
pprGRHSs ctxt (GRHSs grhss binds)
Ian Lynagh's avatar
Ian Lynagh committed
748
749
750
  = vcat (map (pprGRHS ctxt . unLoc) grhss)
 $$ if isEmptyLocalBinds binds then empty
                               else text "where" $$ nest 4 (pprBinds binds)
751

Ian Lynagh's avatar
Ian Lynagh committed
752
753
pprGRHS :: (OutputableBndr idL, OutputableBndr idR)
        => HsMatchContext idL -> GRHS idR -> SDoc
754

755
pprGRHS ctxt (GRHS [] expr)
756
 =  pp_rhs ctxt expr
757

758
pprGRHS ctxt (GRHS guards expr)
759
 = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
760

Ian Lynagh's avatar
Ian Lynagh committed
761
pp_rhs :: OutputableBndr idR => HsMatchContext idL -> LHsExpr idR -> SDoc
762
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
763
\end{code}
764

765
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
766
%*                                                                      *
767
\subsection{Do stmts and list comprehensions}
Ian Lynagh's avatar
Ian Lynagh committed
768
%*                                                                      *
769
770
771
%************************************************************************

\begin{code}
772
773
774
775
type LStmt id = Located (StmtLR id id)
type LStmtLR idL idR = Located (StmtLR idL idR)

type Stmt id = StmtLR id id
776

Ian Lynagh's avatar
Ian Lynagh committed
777
778
779
780
781
782
783
784
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
785

786
787
-- The SyntaxExprs in here are used *only* for do-notation, which
-- has rebindable syntax.  Otherwise they are unused.
788
data StmtLR idL idR
Ian Lynagh's avatar
Ian Lynagh committed
789
790
791
792
793
794
  = 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
795

Ian Lynagh's avatar
Ian Lynagh committed
796
797
798
  | ExprStmt (LHsExpr idR)
             (SyntaxExpr idR) -- The (>>) operator
             PostTcType       -- Element type of the RHS (used for arrows)
799

Ian Lynagh's avatar
Ian Lynagh committed
800
  | LetStmt  (HsLocalBindsLR idL idR)
801

Ian Lynagh's avatar
Ian Lynagh committed
802
803
804
805
  -- 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
806
807

  | TransformStmt ([LStmt idL], [idR]) (LHsExpr idR) (Maybe (LHsExpr idR))
Ian Lynagh's avatar
Ian Lynagh committed
808
809
810
811
  -- 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
812
813

  | GroupStmt ([LStmt idL], [(idR, idR)]) (GroupByClause idR)
Ian Lynagh's avatar
Ian Lynagh committed
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
  -- 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
839
840
\end{code}

841
ExprStmts are a bit tricky, because what they mean
842
depends on the context.  Consider the following contexts:
843

Ian Lynagh's avatar
Ian Lynagh committed
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
        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
864
Array comprehensions are handled like list comprehensions -=chak
865

866
867
868
Note [RecStmt]
~~~~~~~~~~~~~~
Example:
Ian Lynagh's avatar
Ian Lynagh committed
869
        HsDo [ BindStmt x ex
870

Ian Lynagh's avatar
Ian Lynagh committed
871
872
873
874
875
             , RecStmt [a::forall a. a -> a, b]
                       [a::Int -> Int,       c]
                       [ BindStmt b (return x)
                       , LetStmt a = ea
                       , BindStmt c ec ]
876

Ian Lynagh's avatar
Ian Lynagh committed
877
             , return (a b) ]
878

Ian Lynagh's avatar
Ian Lynagh committed
879
880
881
Here, the RecStmt binds a,b,c; but
  - Only a,b are used in the stmts *following* the RecStmt,
        This 'a' is *polymorphic'
882
  - Only a,c are used in the stmts *inside* the RecStmt
Ian Lynagh's avatar
Ian Lynagh committed
883
884
        *before* their bindings
        This 'a' is monomorphic
885
886
887
888
889

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


890
\begin{code}
891
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where
892
893
    ppr stmt = pprStmt stmt

894
pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
895
896
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
897
898
pprStmt (ExprStmt expr _ _)       = ppr expr
pprStmt (ParStmt stmtss)          = hsep (map doStmts stmtss)
Ian Lynagh's avatar
Ian Lynagh committed
899
  where doStmts stmts = ptext (sLit "| ") <> ppr stmts
Ian Lynagh's avatar
Ian Lynagh committed
900
pprStmt (TransformStmt (stmts, _) usingExpr maybeByExpr)
Ian Lynagh's avatar
Ian Lynagh committed
901
    = (hsep [stmtsDoc, ptext (sLit "then"), ppr usingExpr, byExprDoc])
902
  where stmtsDoc = interpp'SP stmts
Ian Lynagh's avatar
Ian Lynagh committed
903
904
        byExprDoc = maybe empty (\byExpr -> hsep [ptext (sLit "by"), ppr byExpr]) maybeByExpr
pprStmt (GroupStmt (stmts, _) groupByClause) = (hsep [stmtsDoc, ptext (sLit "then group"), pprGroupByClause groupByClause])
905
  where stmtsDoc = interpp'SP stmts
Ian Lynagh's avatar
Ian Lynagh committed
906
pprStmt (RecStmt segment _ _ _ _) = ptext (sLit "rec") <+> braces (vcat (map ppr segment))
907

908
pprGroupByClause :: (OutputableBndr id) => GroupByClause id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
909
910
911
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
912

913
pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
914
915
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])
916
917
pprDo ListComp    stmts body = pprComp brackets    stmts body
pprDo PArrComp    stmts body = pprComp pa_brackets stmts body
Ian Lynagh's avatar
Ian Lynagh committed
918
pprDo _           _     _    = panic "pprDo" -- PatGuard, ParStmtCxt
919
920
921

pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc
pprComp brack quals body
922
  = brack $
Ian Lynagh's avatar
Ian Lynagh committed
923
924
        hang (ppr body <+> char '|')
             4 (interpp'SP quals)
925
926
\end{code}

927
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
928
929
930
%*                                                                      *
                Template Haskell quotation brackets
%*                                                                      *
931
932
933
%************************************************************************

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

938
939
940
941
instance OutputableBndr id => Outputable (HsSplice id) where
  ppr = pprSplice

pprSplice :: OutputableBndr id => HsSplice id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
942
943
pprSplice (HsSplice n e)
    = char '$' <> ifPprDebug (brackets (ppr n)) <> pprParendExpr e
944
945


Ian Lynagh's avatar
Ian Lynagh committed
946
947
948
949
950
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
951
952
953
954
955

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


Ian Lynagh's avatar
Ian Lynagh committed
956
pprHsBracket :: OutputableBndr id => HsBracket id -> SDoc
957
958
pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
959
pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d)
960
pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
961
pprHsBracket (VarBr n) = char '\'' <> ppr n
Ian Lynagh's avatar
Ian Lynagh committed
962
963
964
965
-- 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
966

Ian Lynagh's avatar
Ian Lynagh committed
967
thBrackets :: SDoc -> SDoc -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
968
thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
Ian Lynagh's avatar
Ian Lynagh committed
969
                             pp_body <+> ptext (sLit "|]")
970
971
\end{code}

972
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
973
%*                                                                      *
974
\subsection{Enumerations and list comprehensions}
Ian Lynagh's avatar
Ian Lynagh committed
975
%*                                                                      *
976
977
978
%************************************************************************

\begin{code}
979
data ArithSeqInfo id
Ian Lynagh's avatar
Ian Lynagh committed
980
981
982
983
984
985
986
987
  = From            (LHsExpr id)
  | FromThen        (LHsExpr id)
                    (LHsExpr id)
  | FromTo          (LHsExpr id)
                    (LHsExpr id)
  | FromThenTo      (LHsExpr id)
                    (LHsExpr id)
                    (LHsExpr id)
988
989
990
\end{code}

\begin{code}
991
instance OutputableBndr id => Outputable (ArithSeqInfo id) where
Ian Lynagh's avatar
Ian Lynagh committed
992
993
994
    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]
995
996
    ppr (FromThenTo e1 e2 e3)
      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]
997

Ian Lynagh's avatar
Ian Lynagh committed
998
pp_dotdot :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
999
pp_dotdot = ptext (sLit " .. ")
1000
\end{code}
1001
1002
1003


%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
1004
%*                                                                      *
1005
\subsection{HsMatchCtxt}
Ian Lynagh's avatar
Ian Lynagh committed
1006
%*                                                                      *
1007
1008
1009
%************************************************************************

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
data HsMatchContext id  -- Context of a Match
  = FunRhs id Bool              -- Function binding for f; True <=> written infix
  | CaseAlt                     -- Guard on a case alternative
  | LambdaExpr                  -- Pattern of a lambda
  | ProcExpr                    -- Pattern of a proc
  | PatBindRhs                  -- Pattern binding
  | RecUpd                      -- Record update [used only in DsExpr to
                                --    tell matchWrapper what sort of
                                --    runtime error message to generate]
  | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt or list comprehension
1020
1021
  deriving ()

1022
data HsStmtContext id
Ian Lynagh's avatar
Ian Lynagh committed
1023
1024
1025
1026
1027
1028
1029
1030
  = ListComp
  | DoExpr
  | MDoExpr PostTcTable                  -- Recursive do-expression
                                         -- (tiresomely, it needs table
                                         --  of its return/bind ops)
  | PArrComp                             -- Parallel array comprehension
  | PatGuard (HsMatchContext id)         -- Pattern guard for specified thing
  | ParStmtCtxt (HsStmtContext id)       -- A branch of a parallel stmt
1031
  | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt
1032
1033
1034
\end{code}

\begin{code}