HsExpr.lhs 63.4 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
{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
7
8

-- | Abstract Haskell syntax for expressions.
9
10
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
import TcEvidence
22
import CoreSyn
23
import Var
24
import RdrName
25
26
import Name
import BasicTypes
27
import DataCon
28
import SrcLoc
29
import Util
30
import StaticFlags( opt_PprStyle_Debug )
Ian Lynagh's avatar
Ian Lynagh committed
31
import Outputable
32
import FastString
33
34
35

-- libraries:
import Data.Data hiding (Fixity)
36
37
\end{code}

38

39
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
40
%*                                                                      *
41
\subsection{Expressions proper}
Ian Lynagh's avatar
Ian Lynagh committed
42
%*                                                                      *
43
44
45
%************************************************************************

\begin{code}
46
47
-- * Expressions proper

48
49
type LHsExpr id = Located (HsExpr id)

50
-------------------------
51
52
-- | PostTcExpr is an evidence expression attached to the syntax tree by the
-- type checker (c.f. postTcType).
53
type PostTcExpr  = HsExpr Id
54
55
-- | We use a PostTcTable where there are a bunch of pieces of evidence, more
-- than is convenient to keep individually.
56
type PostTcTable = [(Name, PostTcExpr)]
57
58

noPostTcExpr :: PostTcExpr
Ian Lynagh's avatar
Ian Lynagh committed
59
noPostTcExpr = HsLit (HsString (fsLit "noPostTcExpr"))
60
61
62
63
64

noPostTcTable :: PostTcTable
noPostTcTable = []

-------------------------
65
-- | SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier,
Ian Lynagh's avatar
Ian Lynagh committed
66
-- by the renamer.  It's used for rebindable syntax.
67
68
69
--
-- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for
--      @(>>=)@, and then instantiated by the type checker with its type args
70
--      etc
71
72
73

type SyntaxExpr id = HsExpr id

Ian Lynagh's avatar
Ian Lynagh committed
74
75
noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after,
                              -- (if the syntax slot makes no sense)
Ian Lynagh's avatar
Ian Lynagh committed
76
noSyntaxExpr = HsLit (HsString (fsLit "noSyntaxExpr"))
77
78


79
80
type CmdSyntaxTable id = [(Name, SyntaxExpr id)]
-- See Note [CmdSyntaxTable]
81

82
noSyntaxTable :: CmdSyntaxTable id
83
noSyntaxTable = []
84
\end{code}
85

86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
Note [CmdSyntaxtable]
~~~~~~~~~~~~~~~~~~~~~
Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps
track of the methods needed for a Cmd.

* Before the renamer, this list is 'noSyntaxTable'

* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@
  For example, for the 'arr' method
   * normal case:            (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr)
   * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22)
             where @arr_22@ is whatever 'arr' is in scope

* After the type checker, it takes the form [(std_name, <expression>)]
  where <expression> is the evidence for the method.  This evidence is
  instantiated with the class, but is still polymorphic in everything
  else.  For example, in the case of 'arr', the evidence has type
         forall b c. (b->c) -> a b c
  where 'a' is the ambient type of the arrow.  This polymorphism is
  important because the desugarer uses the same evidence at multiple
  different types.

This is Less Cool than what we normally do for rebindable syntax, which is to
make fully-instantiated piece of evidence at every use site.  The Cmd way
is Less Cool because
  * The renamer has to predict which methods are needed.
    See the tedious RnExpr.methodNamesCmd.

  * The desugarer has to know the polymorphic type of the instantiated
    method. This is checked by Inst.tcSyntaxName, but is less flexible
    than the rest of rebindable syntax, where the type is less
    pre-ordained.  (And this flexibility is useful; for example we can
    typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)
119

120
121

\begin{code}
122
-- | A Haskell expression.
123
data HsExpr id
124
125
  = HsVar     id                        -- ^ Variable
  | HsIPVar   HsIPName                  -- ^ Implicit parameter
126
  | HsOverLit (HsOverLit id)            -- ^ Overloaded literals
127

128
  | HsLit     HsLit                     -- ^ Simple (non-overloaded) literals
129

130
  | HsLam     (MatchGroup id (LHsExpr id)) -- ^ Lambda abstraction. Currently always a single match
131

132
  | HsLamCase PostTcType (MatchGroup id (LHsExpr id)) -- ^ Lambda-case
133

134
  | HsApp     (LHsExpr id) (LHsExpr id) -- ^ Application
135

136
  -- | Operator applications:
137
138
  -- NB Bracketed ops such as (+) come out as Vars.

139
140
141
  -- 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
142
143
144
145
146
  | OpApp       (LHsExpr id)    -- left operand
                (LHsExpr id)    -- operator
                Fixity          -- Renamer adds fixity; bottom until then
                (LHsExpr id)    -- right operand

147
148
149
150
  -- | Negation operator. Contains the negated expression and the name
  -- of 'negate'              
  | NegApp      (LHsExpr id) 
                (SyntaxExpr id) 
Ian Lynagh's avatar
Ian Lynagh committed
151

152
  | HsPar       (LHsExpr id)    -- ^ Parenthesised expr; see Note [Parens in HsSyn]
Ian Lynagh's avatar
Ian Lynagh committed
153

154
  | SectionL    (LHsExpr id)    -- operand; see Note [Sections in HsSyn]
Ian Lynagh's avatar
Ian Lynagh committed
155
                (LHsExpr id)    -- operator
156
  | SectionR    (LHsExpr id)    -- operator; see Note [Sections in HsSyn]
Ian Lynagh's avatar
Ian Lynagh committed
157
158
                (LHsExpr id)    -- operand

159
160
  -- | Used for explicit tuples and sections thereof
  | ExplicitTuple               
161
        [HsTupArg id]
162
163
        Boxity

Ian Lynagh's avatar
Ian Lynagh committed
164
  | HsCase      (LHsExpr id)
165
                (MatchGroup id (LHsExpr id))
Ian Lynagh's avatar
Ian Lynagh committed
166

167
  | HsIf        (Maybe (SyntaxExpr id)) -- cond function
168
169
                                        -- Nothing => use the built-in 'if'
                                        -- See Note [Rebindable if]
170
                (LHsExpr id)    --  predicate
Ian Lynagh's avatar
Ian Lynagh committed
171
172
173
                (LHsExpr id)    --  then part
                (LHsExpr id)    --  else part

174
175
  -- | Multi-way if
  | HsMultiIf   PostTcType [LGRHS id (LHsExpr id)] 
176

177
178
  -- | let(rec)
  | HsLet       (HsLocalBinds id) 
Ian Lynagh's avatar
Ian Lynagh committed
179
180
181
182
183
                (LHsExpr  id)

  | HsDo        (HsStmtContext Name) -- The parameterisation is unimportant
                                     -- because in this context we never use
                                     -- the PatGuard or ParStmt variant
184
                [ExprLStmt id]       -- "do":one or more stmts
Ian Lynagh's avatar
Ian Lynagh committed
185
186
                PostTcType           -- Type of the whole expression

187
188
  -- | Syntactic list: [a,b,c,...]
  | ExplicitList                        
189
190
                PostTcType              -- Gives type of components of list
                (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness
Ian Lynagh's avatar
Ian Lynagh committed
191
192
                [LHsExpr id]

193
194
  -- | Syntactic parallel array: [:e1, ..., en:]
  | ExplicitPArr                
Ian Lynagh's avatar
Ian Lynagh committed
195
196
197
                PostTcType      -- type of elements of the parallel array
                [LHsExpr id]

198
  -- | Record construction
Ian Lynagh's avatar
Ian Lynagh committed
199
200
201
202
203
  | 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)

204
  -- | Record update
Ian Lynagh's avatar
Ian Lynagh committed
205
206
  | RecordUpd   (LHsExpr id)
                (HsRecordBinds id)
207
208
--              (HsMatchGroup Id)  -- Filled in by the type checker to be
--                                 -- a match that does the job
Ian Lynagh's avatar
Ian Lynagh committed
209
                [DataCon]          -- Filled in by the type checker to the
Thomas Schilling's avatar
Thomas Schilling committed
210
                                   -- _non-empty_ list of DataCons that have
Ian Lynagh's avatar
Ian Lynagh committed
211
212
213
214
215
216
                                   -- 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

217
218
  -- | Expression with an explicit type signature. @e :: type@  
  | ExprWithTySig                       
219
                (LHsExpr id)
Ian Lynagh's avatar
Ian Lynagh committed
220
221
222
223
224
225
226
                (LHsType id)

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

227
228
  -- | Arithmetic sequence
  | ArithSeq                            
Ian Lynagh's avatar
Ian Lynagh committed
229
                PostTcExpr
230
                (Maybe (SyntaxExpr id))   -- For OverloadedLists, the fromList witness
Ian Lynagh's avatar
Ian Lynagh committed
231
232
                (ArithSeqInfo id)

233
234
  -- | Arithmetic sequence for parallel array
  | PArrSeq                             
Ian Lynagh's avatar
Ian Lynagh committed
235
236
237
238
239
240
241
242
243
                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)

244
  -----------------------------------------------------------
245
  -- MetaHaskell Extensions
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
246

247
  | HsBracket    (HsBracket id)
248

gmainland's avatar
gmainland committed
249
250
251
252
253
254
255
    -- See Note [Pending Renamer Splices]
  | HsRnBracketOut (HsBracket Name)     -- Output of the renamer is
                                        -- the *original*
                   [PendingSplice]      -- renamed expression, plus
                                        -- _renamed_ splices to be
                                        -- type checked

Ian Lynagh's avatar
Ian Lynagh committed
256
257
258
  | HsBracketOut (HsBracket Name)       -- Output of the type checker is
                                        -- the *original*
                 [PendingSplice]        -- renamed expression, plus
Thomas Schilling's avatar
Thomas Schilling committed
259
                                        -- _typechecked_ splices to be
Ian Lynagh's avatar
Ian Lynagh committed
260
                                        -- pasted back in by the desugarer
261

Ian Lynagh's avatar
Ian Lynagh committed
262
  | HsSpliceE (HsSplice id)
263

264
  | HsQuasiQuoteE (HsQuasiQuote id)
265
        -- See Note [Quasi-quote overview] in TcSplice
266

267
268
269
  -----------------------------------------------------------
  -- Arrow notation extension

270
  -- | @proc@ notation for Arrows
Ian Lynagh's avatar
Ian Lynagh committed
271
272
273
  | HsProc      (LPat id)               -- arrow abstraction, proc
                (LHsCmdTop id)          -- body of the abstraction
                                        -- always has an empty stack
274
275
276

  ---------------------------------------
  -- The following are commands, not expressions proper
277
  -- They are only used in the parsing stage and are removed
278
  --    immediately in parser.RdrHsSyn.checkCommand
Ian Lynagh's avatar
Ian Lynagh committed
279
280
281
282
283
284
285
286
  | 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)
287

Ian Lynagh's avatar
Ian Lynagh committed
288
289
290
291
292
293
294
  | 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
295

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
296
297
298
  ---------------------------------------
  -- Haskell program coverage (Hpc) Support

Ian Lynagh's avatar
Ian Lynagh committed
299
  | HsTick
300
     (Tickish id)
Ian Lynagh's avatar
Ian Lynagh committed
301
     (LHsExpr id)                       -- sub-expression
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
302
303

  | HsBinTick
Ian Lynagh's avatar
Ian Lynagh committed
304
305
306
     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
307

Ian Lynagh's avatar
Ian Lynagh committed
308
309
310
  | 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
311
312
313
314

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

Ian Lynagh's avatar
Ian Lynagh committed
316
  | EWildPat                 -- wildcard
317

Ian Lynagh's avatar
Ian Lynagh committed
318
319
  | EAsPat      (Located id) -- as pattern
                (LHsExpr id)
320

Ian Lynagh's avatar
Ian Lynagh committed
321
322
  | EViewPat    (LHsExpr id) -- view pattern
                (LHsExpr id)
323

Ian Lynagh's avatar
Ian Lynagh committed
324
  | ELazyPat    (LHsExpr id) -- ~ pattern
325

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

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
328
329
  ---------------------------------------
  -- Finally, HsWrap appears only in typechecker output
330

Ian Lynagh's avatar
Ian Lynagh committed
331
332
  |  HsWrap     HsWrapper    -- TRANSLATION
                (HsExpr id)
333
  |  HsUnboundVar RdrName
334
  deriving (Data, Typeable)
335

336
-- | HsTupArg is used for tuple sections
337
338
339
--  (,a,) is represented by  ExplicitTuple [Mising ty1, Present a, Missing ty3]
--  Which in turn stands for (\x:ty1 \y:ty2. (x,a,y))
data HsTupArg id
340
341
  = Present (LHsExpr id)        -- ^ The argument
  | Missing PostTcType          -- ^ The argument is missing, but this is its type
342
  deriving (Data, Typeable)
343
344
345
346
347

tupArgPresent :: HsTupArg id -> Bool
tupArgPresent (Present {}) = True
tupArgPresent (Missing {}) = False

gmainland's avatar
gmainland committed
348
349
350
-- See Note [Pending Splices]
data PendingSplice
  = PendingRnExpSplice Name (LHsExpr Name)
gmainland's avatar
gmainland committed
351
  | PendingRnPatSplice Name (LHsExpr Name)
gmainland's avatar
gmainland committed
352
  | PendingRnTypeSplice Name (LHsExpr Name)
353
  | PendingRnDeclSplice Name (LHsExpr Name)
gmainland's avatar
gmainland committed
354
355
356
  | PendingRnCrossStageSplice Name
  | PendingTcSplice Name (LHsExpr Id)
  deriving (Data, Typeable)
357
358
\end{code}

gmainland's avatar
gmainland committed
359
360
361
362
363
364
365
366
367
368
369
370
371
Note [Pending Splices]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Now that untyped brackets are not type checked, we need a mechanism to ensure
that splices contained in untyped brackets *are* type checked. Therefore the
renamer now renames every HsBracket into a HsRnBracketOut, which contains the
splices that need to be type checked. There are three varieties of pending
splices generated by the renamer:

 * Pending expression splices (PendingRnExpSplice), e.g.,

   [|$(f x) + 2|]

gmainland's avatar
gmainland committed
372
373
374
375
 * Pending pattern splices (PendingRnPatSplice), e.g.,

   [|\ $(f x) -> x|]

gmainland's avatar
gmainland committed
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
 * Pending type splices (PendingRnTypeSplice), e.g.,

   [|f :: $(g x)|]

 * Pending cross-stage splices (PendingRnCrossStageSplice), e.g.,

   \x -> [| x |]

There is a fourth variety of pending splice, which is generated by the type
checker:

  * Pending *typed* expression splices, (PendingTcSplice), e.g.,

    [||1 + $$(f 2)||]

It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the
output of the renamer. However, when pretty printing the output of the renamer,
e.g., in a type error message, we *do not* want to print out the pending
splices. In contrast, when pretty printing the output of the type checker, we
*do* want to print the pending splices. So splitting them up seems to make
sense, although I hate to add another constructor to HsExpr.

398
399
400
401
402
403
404
Note [Parens in HsSyn]
~~~~~~~~~~~~~~~~~~~~~~
HsPar (and ParPat in patterns, HsParTy in types) is used as follows

  * Generally HsPar is optional; the pretty printer adds parens where
    necessary.  Eg (HsApp f (HsApp g x)) is fine, and prints 'f (g x)'

405
  * HsPars are pretty printed as '( .. )' regardless of whether
406
407
408
409
410
411
412
413
    or not they are strictly necssary

  * HsPars are respected when rearranging operator fixities.
    So   a * (b + c)  means what it says (where the parens are an HsPar)

Note [Sections in HsSyn]
~~~~~~~~~~~~~~~~~~~~~~~~
Sections should always appear wrapped in an HsPar, thus
414
415
         HsPar (SectionR ...)
The parser parses sections in a wider variety of situations
416
(See Note [Parsing sections]), but the renamer checks for those
417
parens.  This invariant makes pretty-printing easier; we don't need
418
419
a special case for adding the parens round sections.

420
421
422
423
424
425
Note [Rebindable if]
~~~~~~~~~~~~~~~~~~~~
The rebindable syntax for 'if' is a bit special, because when
rebindable syntax is *off* we do not want to treat
   (if c then t else e)
as if it was an application (ifThenElse c t e).  Why not?
426
Because we allow an 'if' to return *unboxed* results, thus
427
428
429
430
431
  if blah then 3# else 4#
whereas that would not be possible using a all to a polymorphic function
(because you can't call a polymorphic function at an unboxed type).

So we use Nothing to mean "use the old built-in typing rule".
432
433

\begin{code}
434
instance OutputableBndr id => Outputable (HsExpr id) where
435
    ppr expr = pprExpr expr
436
437
438
\end{code}

\begin{code}
439
-----------------------
Ian Lynagh's avatar
Ian Lynagh committed
440
-- pprExpr, pprLExpr, pprBinds call pprDeeper;
441
442
-- the underscore versions do not
pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc
443
444
445
pprLExpr (L _ e) = pprExpr e

pprExpr :: OutputableBndr id => HsExpr id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
446
447
448
449
450
451
452
453
454
455
456
457
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
458

Ian Lynagh's avatar
Ian Lynagh committed
459
460
pprBinds :: (OutputableBndr idL, OutputableBndr idR)
         => HsLocalBindsLR idL idR -> SDoc
461
pprBinds b = pprDeeper (ppr b)
462

463
-----------------------
464
465
ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
466

467
ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc
468
ppr_expr (HsVar v)       = pprPrefixOcc v
469
ppr_expr (HsIPVar v)     = ppr v
470
471
ppr_expr (HsLit lit)     = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
Ian Lynagh's avatar
Ian Lynagh committed
472
ppr_expr (HsPar e)       = parens (ppr_lexpr e)
473
474

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

477
478
ppr_expr (HsApp e1 e2)
  = let (fun, args) = collect_args e1 [e2] in
479
    hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))
480
  where
481
482
    collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
    collect_args fun args = (fun, args)
483

Ian Lynagh's avatar
Ian Lynagh committed
484
ppr_expr (OpApp e1 op _ e2)
485
  = case unLoc op of
486
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
487
      _       -> pp_prefixly
488
  where
Ian Lynagh's avatar
Ian Lynagh committed
489
    pp_e1 = pprDebugParendExpr e1   -- In debug mode, add parens
490
    pp_e2 = pprDebugParendExpr e2   -- to make precedence clear
491
492

    pp_prefixly
493
      = hang (ppr op) 2 (sep [pp_e1, pp_e2])
494
495

    pp_infixly v
496
      = sep [pp_e1, sep [pprInfixOcc v, nest 2 pp_e2]]
497

498
ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
499

500
ppr_expr (SectionL expr op)
501
  = case unLoc op of
502
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
503
      _       -> pp_prefixly
504
  where
505
    pp_expr = pprDebugParendExpr expr
506

507
    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
Ian Lynagh's avatar
Ian Lynagh committed
508
                       4 (hsep [pp_expr, ptext (sLit "x_ )")])
509
    pp_infixly v = (sep [pp_expr, pprInfixOcc v])
510

511
ppr_expr (SectionR op expr)
512
  = case unLoc op of
513
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
514
      _       -> pp_prefixly
515
  where
516
    pp_expr = pprDebugParendExpr expr
517

Ian Lynagh's avatar
Ian Lynagh committed
518
    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")])
519
                       4 (pp_expr <> rparen)
520
    pp_infixly v = sep [pprInfixOcc v, pp_expr]
521

522
ppr_expr (ExplicitTuple exprs boxity)
batterseapower's avatar
batterseapower committed
523
  = tupleParens (boxityNormalTupleSort boxity) (fcat (ppr_tup_args exprs))
524
525
526
  where
    ppr_tup_args []               = []
    ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
527
    ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
528
529
530
531
532

    punc (Present {} : _) = comma <> space
    punc (Missing {} : _) = comma
    punc []               = empty

533
--avoid using PatternSignatures for stage1 code portability
534
535
ppr_expr (HsLam matches)
  = pprMatches (LambdaExpr :: HsMatchContext id) matches
536

537
538
539
540
ppr_expr (HsLamCase _ matches)
  = sep [ sep [ptext (sLit "\\case {")],
          nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]

541
ppr_expr (HsCase expr matches)
542
  = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")],
543
          nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
544

545
ppr_expr (HsIf _ e1 e2 e3)
Ian Lynagh's avatar
Ian Lynagh committed
546
  = sep [hsep [ptext (sLit "if"), nest 2 (ppr e1), ptext (sLit "then")],
Ian Lynagh's avatar
Ian Lynagh committed
547
         nest 4 (ppr e2),
Ian Lynagh's avatar
Ian Lynagh committed
548
         ptext (sLit "else"),
Ian Lynagh's avatar
Ian Lynagh committed
549
         nest 4 (ppr e3)]
550

551
552
553
554
555
556
ppr_expr (HsMultiIf _ alts)
  = sep $ ptext (sLit "if") : map ppr_alt alts
  where ppr_alt (L _ (GRHS guards expr)) =
          sep [ char '|' <+> interpp'SP guards
              , ptext (sLit "->") <+> pprDeeper (ppr expr) ]

557
-- special case: let ... in let ...
558
ppr_expr (HsLet binds expr@(L _ (HsLet _ _)))
Ian Lynagh's avatar
Ian Lynagh committed
559
  = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]),
Ian Lynagh's avatar
Ian Lynagh committed
560
         ppr_lexpr expr]
561

562
ppr_expr (HsLet binds expr)
Ian Lynagh's avatar
Ian Lynagh committed
563
564
  = sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
         hang (ptext (sLit "in"))  2 (ppr expr)]
565

566
ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
567

568
ppr_expr (ExplicitList _ _ exprs)
569
  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
570

chak's avatar
chak committed
571
ppr_expr (ExplicitPArr _ exprs)
572
  = paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
chak's avatar
chak committed
573

Ian Lynagh's avatar
Ian Lynagh committed
574
ppr_expr (RecordCon con_id _ rbinds)
575
  = hang (ppr con_id) 2 (ppr rbinds)
576

577
ppr_expr (RecordUpd aexp rbinds _ _ _)
578
  = hang (pprParendExpr aexp) 2 (ppr rbinds)
579
580

ppr_expr (ExprWithTySig expr sig)
581
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
Ian Lynagh's avatar
Ian Lynagh committed
582
         4 (ppr sig)
583
584
ppr_expr (ExprWithTySigOut expr sig)
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
Ian Lynagh's avatar
Ian Lynagh committed
585
         4 (ppr sig)
586

587
ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
588
ppr_expr (PArrSeq  _ info) = paBrackets (ppr info)
chak's avatar
chak committed
589

Ian Lynagh's avatar
Ian Lynagh committed
590
591
592
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
593
ppr_expr (EViewPat p e) = ppr p <+> ptext (sLit "->") <+> ppr e
594
595

ppr_expr (HsSCC lbl expr)
596
  = sep [ ptext (sLit "{-# SCC") <+> doubleQuotes (ftext lbl) <+> ptext (sLit "#-}"),
Ian Lynagh's avatar
Ian Lynagh committed
597
          pprParendExpr expr ]
598

599
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
Ian Lynagh's avatar
Ian Lynagh committed
600
ppr_expr (HsType id)      = ppr id
chak's avatar
chak committed
601

gmainland's avatar
gmainland committed
602
603
604
605
606
607
ppr_expr (HsSpliceE s)        = pprSplice s
ppr_expr (HsBracket b)        = pprHsBracket b
ppr_expr (HsRnBracketOut e _) = ppr e
ppr_expr (HsBracketOut e [])  = ppr e
ppr_expr (HsBracketOut e ps)  = ppr e $$ ptext (sLit "pending") <+> ppr ps
ppr_expr (HsQuasiQuoteE qq)   = ppr qq
608

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

612
ppr_expr (HsTick tickish exp)
613
  = pprTicks (ppr exp) $
614
    ppr tickish <+> ppr exp
andy@galois.com's avatar
andy@galois.com committed
615
ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
616
617
  = pprTicks (ppr exp) $
    hcat [ptext (sLit "bintick<"),
Ian Lynagh's avatar
Ian Lynagh committed
618
          ppr tickIdTrue,
Ian Lynagh's avatar
Ian Lynagh committed
619
          ptext (sLit ","),
Ian Lynagh's avatar
Ian Lynagh committed
620
          ppr tickIdFalse,
Ian Lynagh's avatar
Ian Lynagh committed
621
622
          ptext (sLit ">("),
          ppr exp,ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
623
ppr_expr (HsTickPragma externalSrcLoc exp)
624
625
  = pprTicks (ppr exp) $
    hcat [ptext (sLit "tickpragma<"),
Ian Lynagh's avatar
Ian Lynagh committed
626
          ppr externalSrcLoc,
Ian Lynagh's avatar
Ian Lynagh committed
627
          ptext (sLit ">("),
Ian Lynagh's avatar
Ian Lynagh committed
628
          ppr exp,
Ian Lynagh's avatar
Ian Lynagh committed
629
          ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
630

631
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
Ian Lynagh's avatar
Ian Lynagh committed
632
  = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg]
633
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
Ian Lynagh's avatar
Ian Lynagh committed
634
  = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow]
635
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
Ian Lynagh's avatar
Ian Lynagh committed
636
  = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg]
637
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
Ian Lynagh's avatar
Ian Lynagh committed
638
  = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
639

640
ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
641
  = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
642
ppr_expr (HsArrForm op _ args)
643
644
  = hang (ptext (sLit "(|") <+> ppr_lexpr op)
         4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)"))
645
646
ppr_expr (HsUnboundVar nm)
  = ppr nm
647

648
649
\end{code}

650
651
652
653
654
655
656
657
658
659
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.

660
\begin{code}
661
662
663
664
pprDebugParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
pprDebugParendExpr expr
  = getPprStyle (\sty ->
    if debugStyle sty then pprParendExpr expr
Ian Lynagh's avatar
Ian Lynagh committed
665
666
                      else pprLExpr      expr)

667
pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
668
pprParendExpr expr
669
670
  | hsExprNeedsParens (unLoc expr) = parens (pprLExpr expr)
  | otherwise                      = pprLExpr expr
Ian Lynagh's avatar
Ian Lynagh committed
671
672
        -- Using pprLExpr makes sure that we go 'deeper'
        -- I think that is usually (always?) right
673
674

hsExprNeedsParens :: HsExpr id -> Bool
675
-- True of expressions for which '(e)' and 'e'
676
677
678
679
680
681
-- mean the same thing
hsExprNeedsParens (ArithSeq {})       = False
hsExprNeedsParens (PArrSeq {})        = False
hsExprNeedsParens (HsLit {})          = False
hsExprNeedsParens (HsOverLit {})      = False
hsExprNeedsParens (HsVar {})          = False
682
hsExprNeedsParens (HsUnboundVar {})   = False
683
684
685
686
687
688
hsExprNeedsParens (HsIPVar {})        = False
hsExprNeedsParens (ExplicitTuple {})  = False
hsExprNeedsParens (ExplicitList {})   = False
hsExprNeedsParens (ExplicitPArr {})   = False
hsExprNeedsParens (HsPar {})          = False
hsExprNeedsParens (HsBracket {})      = False
gmainland's avatar
gmainland committed
689
hsExprNeedsParens (HsRnBracketOut {}) = False
690
691
692
693
694
695
hsExprNeedsParens (HsBracketOut _ []) = False
hsExprNeedsParens (HsDo sc _ _)
       | isListCompExpr sc            = False
hsExprNeedsParens _ = True


696
isAtomicHsExpr :: HsExpr id -> Bool
697
-- True of a single token
698
699
700
701
isAtomicHsExpr (HsVar {})     = True
isAtomicHsExpr (HsLit {})     = True
isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {})   = True
702
isAtomicHsExpr (HsUnboundVar {}) = True
703
704
isAtomicHsExpr (HsWrap _ e)   = isAtomicHsExpr e
isAtomicHsExpr (HsPar e)      = isAtomicHsExpr (unLoc e)
Ian Lynagh's avatar
Ian Lynagh committed
705
isAtomicHsExpr _              = False
706
707
\end{code}

708
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
709
%*                                                                      *
710
\subsection{Commands (in arrow abstractions)}
Ian Lynagh's avatar
Ian Lynagh committed
711
%*                                                                      *
712
713
714
715
716
%************************************************************************

We re-use HsExpr to represent these.

\begin{code}
717
type LHsCmd id = Located (HsCmd id)
718

719
data HsCmd id
720
721
722
723
724
725
726
727
  = HsCmdArrApp         -- 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)
728

729
730
731
732
733
734
735
  | HsCmdArrForm        -- 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
736

737
738
  | HsCmdApp    (LHsCmd id)
                (LHsExpr id)
739

740
  | HsCmdLam    (MatchGroup id (LHsCmd id))     -- kappa
ross's avatar
ross committed
741

742
  | HsCmdPar    (LHsCmd id)                     -- parenthesised command
743

744
745
  | HsCmdCase   (LHsExpr id)
                (MatchGroup id (LHsCmd id))     -- bodies are HsCmd's
746

747
748
749
750
  | HsCmdIf     (Maybe (SyntaxExpr id))         -- cond function
                (LHsExpr id)                    -- predicate
                (LHsCmd id)                     -- then part
                (LHsCmd id)                     -- else part
751

752
753
  | HsCmdLet    (HsLocalBinds id)               -- let(rec)
                (LHsCmd  id)
754

755
756
  | HsCmdDo     [CmdLStmt id]
                PostTcType                      -- Type of the whole expression
757
758
759
760
761
762

  | HsCmdCast   TcCoercion     -- A simpler version of HsWrap in HsExpr
                (HsCmd id)     -- If   cmd :: arg1 --> res
                               --       co :: arg1 ~ arg2
                               -- Then (HsCmdCast co cmd) :: arg2 --> res
                
763
  deriving (Data, Typeable)
764

765
766
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
  deriving (Data, Typeable)
767

768
\end{code}
769
770
771
772
773
774

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

777
data HsCmdTop id
Ian Lynagh's avatar
Ian Lynagh committed
778
  = HsCmdTop (LHsCmd id)
779
             PostTcType          -- Nested tuple of inputs on the command's stack
780
781
             PostTcType          -- return type of the command
             (CmdSyntaxTable id) -- See Note [CmdSyntaxTable]
782
  deriving (Data, Typeable)
783
784
\end{code}

785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
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
839
840
841
842
843
844
845

\begin{code}
instance OutputableBndr id => Outputable (HsCmd id) where
    ppr cmd = pprCmd cmd

-----------------------
-- pprCmd and pprLCmd call pprDeeper;
-- the underscore versions do not
pprLCmd :: OutputableBndr id => LHsCmd id -> SDoc
pprLCmd (L _ c) = pprCmd c

pprCmd :: OutputableBndr id => HsCmd id -> SDoc
pprCmd c | isQuietHsCmd c =            ppr_cmd c
         | otherwise      = pprDeeper (ppr_cmd c)

isQuietHsCmd :: HsCmd 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 (...)
isQuietHsCmd (HsCmdPar _) = True
-- applications don't display anything themselves
isQuietHsCmd (HsCmdApp _ _) = True
isQuietHsCmd _ = False

-----------------------
ppr_lcmd :: OutputableBndr id => LHsCmd id -> SDoc
ppr_lcmd c = ppr_cmd (unLoc c)

ppr_cmd :: forall id. OutputableBndr id => HsCmd id -> SDoc
ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c)

ppr_cmd (HsCmdApp c e)
  = let (fun, args) = collect_args c [e] in
    hang (ppr_lcmd fun) 2 (sep (map pprParendExpr args))
  where
    collect_args (L _ (HsCmdApp fun arg)) args = collect_args fun (arg:args)
    collect_args fun args = (fun, args)

--avoid using PatternSignatures for stage1 code portability
ppr_cmd (HsCmdLam matches)
  = pprMatches (LambdaExpr :: HsMatchContext id) matches

ppr_cmd (HsCmdCase expr matches)
  = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")],
          nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]

ppr_cmd (HsCmdIf _ e ct ce)
  = sep [hsep [ptext (sLit "if"), nest 2 (ppr e), ptext (sLit "then")],
         nest 4 (ppr ct),
         ptext (sLit "else"),
         nest 4 (ppr ce)]

-- special case: let ... in let ...
ppr_cmd (HsCmdLet binds cmd@(L _ (HsCmdLet _ _)))
  = sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]),
         ppr_lcmd cmd]

ppr_cmd (HsCmdLet binds cmd)
  = sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
         hang (ptext (sLit "in"))  2 (ppr cmd)]

846
847
848
ppr_cmd (HsCmdDo stmts _)  = pprDo ArrowExpr stmts
ppr_cmd (HsCmdCast co cmd) = sep [ ppr_cmd cmd
                                 , ptext (sLit "|>") <+> ppr co ]
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875

ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True)
  = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg]
ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp False)
  = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow]
ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True)
  = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg]
ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False)
  = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]

ppr_cmd (HsCmdArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
  = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
ppr_cmd (HsCmdArrForm op _ args)
  = hang (ptext (sLit "(|") <> ppr_lexpr op)
         4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))

pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
pprCmdArg (HsCmdTop cmd@(L _ (HsCmdArrForm _ Nothing [])) _ _ _)
  = ppr_lcmd cmd
pprCmdArg (HsCmdTop cmd _ _ _)
  = parens (ppr_lcmd cmd)

instance OutputableBndr id => Outputable (HsCmdTop id) where
    ppr = pprCmdArg

\end{code}

876
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
877
%*                                                                      *
878
\subsection{Record binds}
Ian Lynagh's avatar
Ian Lynagh committed
879
%*                                                                      *
880
881
882
%************************************************************************

\begin{code}
883
type HsRecordBinds id = HsRecFields id (LHsExpr id)
884
885
\end{code}

886

887
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
888
%*                                                                      *
889
\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
Ian Lynagh's avatar
Ian Lynagh committed
890
%*                                                                      *
891
892
%************************************************************************

893
894
895
896
897
898
899
900
901
902
903
904
905
906
@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.

907
\begin{code}
908
data MatchGroup id body
909
910
911
912
913
914
  = MG { mg_alts    :: [LMatch id body]  -- The alternatives
       , mg_arg_tys :: [PostTcType]      -- Types of the arguments, t1..tn
       , mg_res_ty  :: PostTcType  }     -- Type of the result, tr 
     -- The type is the type of the entire group
     --      t1 -> ... -> tn -> tr
     -- where there are n patterns
915
  deriving (Data, Typeable)
916

917
type LMatch id body = Located (Match id body)
918

919
data Match id body
920
  = Match
Ian Lynagh's avatar
Ian Lynagh committed
921
922
923
        [LPat id]               -- The patterns
        (Maybe (LHsType id))    -- A type signature for the result of the match
                                -- Nothing after typechecking
924
        (GRHSs id body)
925
  deriving (Data, Typeable)
926

927
isEmptyMatchGroup :: MatchGroup id body -> Bool
928
isEmptyMatchGroup (MG { mg_alts = ms }) = null ms
929

930
matchGroupArity :: MatchGroup id body -> Arity
931
932
933
934
935
-- Precondition: MatchGroup is non-empty
-- This is called before type checking, when mg_arg_tys is not set
matchGroupArity (MG { mg_alts = alts })
  | (alt1:_) <- alts = length (hsLMatchPats alt1)
  | otherwise        = panic "matchGroupArity"
936

937
hsLMatchPats :: LMatch id body -> [LPat id]
938
939
hsLMatchPats (L _ (Match pats _ _)) = pats

940
-- | GRHSs are used both for pattern bindings and for Matches
941
data GRHSs id body
942
  = GRHSs {
943
      grhssGRHSs :: [LGRHS id body],       -- ^ Guarded RHSs
944
      grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause
945
    } deriving (Data, Typeable)
946

947
type LGRHS id body = Located (GRHS id body)
948

949
-- | Guarded Right Hand Side.
950
951
data GRHS id body = GRHS [GuardLStmt id] -- Guards
                         body            -- Right hand side
952
  deriving (Data, Typeable)
953
\end{code}
954

955
We know the list must have at least one @Match@ in it.
956

957
\begin{code}
958
959
pprMatches :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
           => HsMatchContext idL -> MatchGroup idR body -> SDoc
960
pprMatches ctxt (MG { mg_alts = matches })
Ian Lynagh's avatar
Ian Lynagh committed
961
    = vcat (map (pprMatch ctxt) (map unLoc matches))
Ian Lynagh's avatar
Ian Lynagh committed
962
      -- Don't print the type; it's only a place-holder before typechecking
963
964

-- Exported to HsBinds, which can't see the defn of HsMatchContext
965
pprFunBind :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
966
           => idL -> Bool -> MatchGroup idR body -> SDoc
967
pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
968
969

-- Exported to HsBinds, which can't see the defn of HsMatchContext
970
971
pprPatBind :: forall bndr id body. (OutputableBndr bndr, OutputableBndr id, Outputable body)
           => LPat bndr -> GRHSs id body -> SDoc
972
973
pprPatBind pat (grhss)
 = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)]
974

975
976
pprMatch :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
         => HsMatchContext idL -> Match idR body -> SDoc
977
pprMatch ctxt (Match pats maybe_ty grhss)
978
979
980
  = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
        , nest 2 ppr_maybe_ty
        , nest 2 (pprGRHSs ctxt grhss) ]
981
  where
Ian Lynagh's avatar
Ian Lynagh committed
982
983
984
    (herald, other_pats)
        = case ctxt of
            FunRhs fun is_infix
985
                | not is_infix -> (pprPrefixOcc fun, pats)
Ian Lynagh's avatar
Ian Lynagh committed
986
987
988
989
                        -- f x y z = e
                        -- Not pprBndr; the AbsBinds will
                        -- have printed the signature

990
                | null pats2 -> (pp_infix, [])
Ian Lynagh's avatar
Ian Lynagh committed
991
992
                        -- x &&& y = e

993
                | otherwise -> (parens pp_infix, pats2)
Ian Lynagh's avatar
Ian Lynagh committed
994
995
                        -- (x &&& y) z = e
                where
996
                  pp_infix = pprParendLPat pat1 <+> pprInfixOcc fun <+> pprParendLPat pat2
Ian Lynagh's avatar
Ian Lynagh committed
997
998

            LambdaExpr -> (char '\\', pats)
999

1000
            _  -> ASSERT( null pats1 )
1001
                  (ppr pat1, [])        -- No parens around the single pat
1002

1003
1004
    (pat1:pats1) = pats
    (pat2:pats2) = pats1
1005
    ppr_maybe_ty = case maybe_ty of
Ian Lynagh's avatar
Ian Lynagh committed
1006
1007
                        Just ty -> dcolon <+> ppr ty
                        Nothing -> empty
1008
1009


1010
1011
pprGRHSs :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
         => HsMatchContext idL -> GRHSs idR body -> SDoc
1012
pprGRHSs ctxt (GRHSs grhss binds)
Ian Lynagh's avatar
Ian Lynagh committed
1013
  = vcat (map (pprGRHS ctxt . unLoc) grhss)
1014
1015
 $$ ppUnless (isEmptyLocalBinds binds)
      (text "where" $$ nest 4 (pprBinds binds))