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

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

10
#include "HsVersions.h"
11
12

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

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

29

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

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

39
40
type LHsExpr id = Located (HsExpr id)

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

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

noPostTcTable :: PostTcTable
noPostTcTable = []

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

type SyntaxExpr id = HsExpr id

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


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

noSyntaxTable :: SyntaxTable id
noSyntaxTable = []


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

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

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

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
  | 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

124
125
126
127
  | ExplicitTuple		-- Used for explicit tuples and sections thereof
        [HsTupArg id] 
        Boxity

Ian Lynagh's avatar
Ian Lynagh committed
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
  | 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]

  -- 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)
163
164
--		(HsMatchGroup Id)  -- Filled in by the type checker to be 
--				   -- a match that does the job
Ian Lynagh's avatar
Ian Lynagh committed
165
                [DataCon]          -- Filled in by the type checker to the
Thomas Schilling's avatar
Thomas Schilling committed
166
                                   -- _non-empty_ list of DataCons that have
Ian Lynagh's avatar
Ian Lynagh committed
167
168
169
170
171
172
173
                                   -- 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
174
                (LHsExpr id)
Ian Lynagh's avatar
Ian Lynagh committed
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
                (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)

196
  -----------------------------------------------------------
197
  -- MetaHaskell Extensions
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
198

199
  | HsBracket    (HsBracket id)
200

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

Ian Lynagh's avatar
Ian Lynagh committed
207
  | HsSpliceE (HsSplice id)
208

209
210
211
  | HsQuasiQuoteE (HsQuasiQuote id)
	-- See Note [Quasi-quote overview] in TcSplice

212
213
214
  -----------------------------------------------------------
  -- Arrow notation extension

Ian Lynagh's avatar
Ian Lynagh committed
215
216
217
  | HsProc      (LPat id)               -- arrow abstraction, proc
                (LHsCmdTop id)          -- body of the abstraction
                                        -- always has an empty stack
218
219
220
221

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

Ian Lynagh's avatar
Ian Lynagh committed
222
223
224
225
226
227
228
229
  | 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)
230

Ian Lynagh's avatar
Ian Lynagh committed
231
232
233
234
235
236
237
  | 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
238

239

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
240
241
242
  ---------------------------------------
  -- Haskell program coverage (Hpc) Support

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

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

Ian Lynagh's avatar
Ian Lynagh committed
253
254
255
  | 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
256
257
258
259

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

Ian Lynagh's avatar
Ian Lynagh committed
261
  | EWildPat                 -- wildcard
262

Ian Lynagh's avatar
Ian Lynagh committed
263
264
  | EAsPat      (Located id) -- as pattern
                (LHsExpr id)
265

Ian Lynagh's avatar
Ian Lynagh committed
266
267
  | EViewPat    (LHsExpr id) -- view pattern
                (LHsExpr id)
268

Ian Lynagh's avatar
Ian Lynagh committed
269
  | ELazyPat    (LHsExpr id) -- ~ pattern
270

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

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
273
274
  ---------------------------------------
  -- Finally, HsWrap appears only in typechecker output
275

Ian Lynagh's avatar
Ian Lynagh committed
276
277
  |  HsWrap     HsWrapper    -- TRANSLATION
                (HsExpr id)
278

279
280
281
282
283
284
285
286
287
288
289
-- HsTupArg is used for tuple sections
--  (,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
  = Present (LHsExpr id)	-- The argument
  | Missing PostTcType		-- The argument is missing, but this is its type

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

Ian Lynagh's avatar
Ian Lynagh committed
290
291
type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be
                                        -- pasted back in by the desugarer
292
293
294
295
296
297
298
299
300
\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}
301
instance OutputableBndr id => Outputable (HsExpr id) where
302
    ppr expr = pprExpr expr
303
304
305
\end{code}

\begin{code}
306
-----------------------
Ian Lynagh's avatar
Ian Lynagh committed
307
-- pprExpr, pprLExpr, pprBinds call pprDeeper;
308
309
-- the underscore versions do not
pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc
310
311
312
pprLExpr (L _ e) = pprExpr e

pprExpr :: OutputableBndr id => HsExpr id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
313
314
315
316
317
318
319
320
321
322
323
324
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
325

Ian Lynagh's avatar
Ian Lynagh committed
326
327
pprBinds :: (OutputableBndr idL, OutputableBndr idR)
         => HsLocalBindsLR idL idR -> SDoc
328
pprBinds b = pprDeeper (ppr b)
329

330
-----------------------
331
332
ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
333

334
ppr_expr :: OutputableBndr id => HsExpr id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
335
ppr_expr (HsVar v)       = pprHsVar v
336
ppr_expr (HsIPVar v)     = ppr v
337
338
ppr_expr (HsLit lit)     = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
Ian Lynagh's avatar
Ian Lynagh committed
339
ppr_expr (HsPar e)       = parens (ppr_lexpr e)
340
341

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

344
345
ppr_expr (HsApp e1 e2)
  = let (fun, args) = collect_args e1 [e2] in
346
    hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))
347
  where
348
349
    collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
    collect_args fun args = (fun, args)
350

Ian Lynagh's avatar
Ian Lynagh committed
351
ppr_expr (OpApp e1 op _ e2)
352
  = case unLoc op of
353
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
354
      _       -> pp_prefixly
355
  where
Ian Lynagh's avatar
Ian Lynagh committed
356
    pp_e1 = pprDebugParendExpr e1   -- In debug mode, add parens
357
    pp_e2 = pprDebugParendExpr e2   -- to make precedence clear
358
359

    pp_prefixly
360
      = hang (ppr op) 2 (sep [pp_e1, pp_e2])
361
362

    pp_infixly v
363
      = sep [nest 2 pp_e1, pprHsInfix v, nest 2 pp_e2]
364

365
ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
366

367
ppr_expr (SectionL expr op)
368
  = case unLoc op of
369
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
370
      _       -> pp_prefixly
371
  where
372
    pp_expr = pprDebugParendExpr expr
373

374
    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
Ian Lynagh's avatar
Ian Lynagh committed
375
                       4 (hsep [pp_expr, ptext (sLit "x_ )")])
376
    pp_infixly v = (sep [pp_expr, pprHsInfix v])
377

378
ppr_expr (SectionR op expr)
379
  = case unLoc op of
380
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
381
      _       -> pp_prefixly
382
  where
383
    pp_expr = pprDebugParendExpr expr
384

Ian Lynagh's avatar
Ian Lynagh committed
385
    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")])
Ian Lynagh's avatar
Ian Lynagh committed
386
                       4 ((<>) pp_expr rparen)
387
    pp_infixly v
388
      = (sep [pprHsInfix v, pp_expr])
389

390
391
392
393
394
ppr_expr (ExplicitTuple exprs boxity)
  = tupleParens boxity (fcat (ppr_tup_args exprs))
  where
    ppr_tup_args []               = []
    ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
395
    ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
396
397
398
399
400

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

401
402
403
404
--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
405

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

411
ppr_expr (HsIf e1 e2 e3)
Ian Lynagh's avatar
Ian Lynagh committed
412
  = sep [hsep [ptext (sLit "if"), nest 2 (ppr e1), ptext (sLit "then")],
Ian Lynagh's avatar
Ian Lynagh committed
413
         nest 4 (ppr e2),
Ian Lynagh's avatar
Ian Lynagh committed
414
         ptext (sLit "else"),
Ian Lynagh's avatar
Ian Lynagh committed
415
         nest 4 (ppr e3)]
416
417

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

422
ppr_expr (HsLet binds expr)
Ian Lynagh's avatar
Ian Lynagh committed
423
424
  = sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
         hang (ptext (sLit "in"))  2 (ppr expr)]
425

426
ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body
427

428
ppr_expr (ExplicitList _ exprs)
429
  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
430

chak's avatar
chak committed
431
ppr_expr (ExplicitPArr _ exprs)
432
  = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
chak's avatar
chak committed
433

Ian Lynagh's avatar
Ian Lynagh committed
434
ppr_expr (RecordCon con_id _ rbinds)
435
  = hang (ppr con_id) 2 (ppr rbinds)
436

437
ppr_expr (RecordUpd aexp rbinds _ _ _)
438
  = hang (pprParendExpr aexp) 2 (ppr rbinds)
439
440

ppr_expr (ExprWithTySig expr sig)
441
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
Ian Lynagh's avatar
Ian Lynagh committed
442
         4 (ppr sig)
443
444
ppr_expr (ExprWithTySigOut expr sig)
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
Ian Lynagh's avatar
Ian Lynagh committed
445
         4 (ppr sig)
446

Ian Lynagh's avatar
Ian Lynagh committed
447
448
ppr_expr (ArithSeq _ info) = brackets (ppr info)
ppr_expr (PArrSeq  _ info) = pa_brackets (ppr info)
chak's avatar
chak committed
449

Ian Lynagh's avatar
Ian Lynagh committed
450
451
452
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
453
ppr_expr (EViewPat p e) = ppr p <+> ptext (sLit "->") <+> ppr e
454
455

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

459
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
Ian Lynagh's avatar
Ian Lynagh committed
460
ppr_expr (HsType id)      = ppr id
chak's avatar
chak committed
461

462
463
ppr_expr (HsSpliceE s)       = pprSplice s
ppr_expr (HsBracket b)       = pprHsBracket b
Ian Lynagh's avatar
Ian Lynagh committed
464
ppr_expr (HsBracketOut e []) = ppr e
Ian Lynagh's avatar
Ian Lynagh committed
465
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending") <+> ppr ps
466
ppr_expr (HsQuasiQuoteE qq)  = ppr qq
467

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

471
ppr_expr (HsTick tickId vars exp)
Ian Lynagh's avatar
Ian Lynagh committed
472
  = hcat [ptext (sLit "tick<"),
Ian Lynagh's avatar
Ian Lynagh committed
473
          ppr tickId,
Ian Lynagh's avatar
Ian Lynagh committed
474
          ptext (sLit ">("),
Ian Lynagh's avatar
Ian Lynagh committed
475
476
          hsep (map pprHsVar vars),
          ppr exp,
Ian Lynagh's avatar
Ian Lynagh committed
477
          ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
478
ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
Ian Lynagh's avatar
Ian Lynagh committed
479
  = hcat [ptext (sLit "bintick<"),
Ian Lynagh's avatar
Ian Lynagh committed
480
          ppr tickIdTrue,
Ian Lynagh's avatar
Ian Lynagh committed
481
          ptext (sLit ","),
Ian Lynagh's avatar
Ian Lynagh committed
482
          ppr tickIdFalse,
Ian Lynagh's avatar
Ian Lynagh committed
483
484
          ptext (sLit ">("),
          ppr exp,ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
485
ppr_expr (HsTickPragma externalSrcLoc exp)
Ian Lynagh's avatar
Ian Lynagh committed
486
  = hcat [ptext (sLit "tickpragma<"),
Ian Lynagh's avatar
Ian Lynagh committed
487
          ppr externalSrcLoc,
Ian Lynagh's avatar
Ian Lynagh committed
488
          ptext (sLit ">("),
Ian Lynagh's avatar
Ian Lynagh committed
489
          ppr exp,
Ian Lynagh's avatar
Ian Lynagh committed
490
          ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
491

492
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
Ian Lynagh's avatar
Ian Lynagh committed
493
  = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg]
494
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
Ian Lynagh's avatar
Ian Lynagh committed
495
  = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow]
496
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
Ian Lynagh's avatar
Ian Lynagh committed
497
  = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg]
498
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
Ian Lynagh's avatar
Ian Lynagh committed
499
  = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
500

501
ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
502
  = sep [pprCmdArg (unLoc arg1), hsep [pprHsInfix v, pprCmdArg (unLoc arg2)]]
503
ppr_expr (HsArrForm op _ args)
Ian Lynagh's avatar
Ian Lynagh committed
504
505
  = hang (ptext (sLit "(|") <> ppr_lexpr op)
         4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
506
507

pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
508
509
510
511
pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
  = ppr_lexpr cmd
pprCmdArg (HsCmdTop cmd _ _ _)
  = parens (ppr_lexpr cmd)
512

Ian Lynagh's avatar
Ian Lynagh committed
513
514
515
instance OutputableBndr id => Outputable (HsCmdTop id) where
    ppr = pprCmdArg

chak's avatar
chak committed
516
517
-- add parallel array brackets around a document
--
518
pa_brackets :: SDoc -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
519
pa_brackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
520
521
\end{code}

522
523
524
525
526
527
528
529
530
531
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.

532
\begin{code}
533
534
535
536
pprDebugParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
pprDebugParendExpr expr
  = getPprStyle (\sty ->
    if debugStyle sty then pprParendExpr expr
Ian Lynagh's avatar
Ian Lynagh committed
537
538
                      else pprLExpr      expr)

539
pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
540
pprParendExpr expr
541
  = let
Ian Lynagh's avatar
Ian Lynagh committed
542
543
544
        pp_as_was = pprLExpr expr
        -- Using pprLExpr makes sure that we go 'deeper'
        -- I think that is usually (always?) right
545
    in
546
    case unLoc expr of
547
548
549
550
551
552
553
554
555
556
557
558
      ArithSeq {}       -> pp_as_was
      PArrSeq {}        -> pp_as_was
      HsLit {}          -> pp_as_was
      HsOverLit {}      -> pp_as_was
      HsVar {}          -> pp_as_was
      HsIPVar {}        -> pp_as_was
      ExplicitTuple {}  -> pp_as_was
      ExplicitList {}   -> pp_as_was
      ExplicitPArr {}   -> pp_as_was
      HsPar {}          -> pp_as_was
      HsBracket {}      -> pp_as_was
      HsBracketOut _ [] -> pp_as_was
559
560
      HsDo sc _ _ _
       | isListCompExpr sc -> pp_as_was
Ian Lynagh's avatar
Ian Lynagh committed
561
      _                    -> parens pp_as_was
562

Ian Lynagh's avatar
Ian Lynagh committed
563
isAtomicHsExpr :: HsExpr id -> Bool -- A single token
564
565
566
567
568
569
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
570
isAtomicHsExpr _              = False
571
572
\end{code}

573
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
574
%*                                                                      *
575
\subsection{Commands (in arrow abstractions)}
Ian Lynagh's avatar
Ian Lynagh committed
576
%*                                                                      *
577
578
579
580
581
582
583
%************************************************************************

We re-use HsExpr to represent these.

\begin{code}
type HsCmd id = HsExpr id

584
585
type LHsCmd id = LHsExpr id

586
587
588
589
590
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
\end{code}

The legal constructors for commands are:

Ian Lynagh's avatar
Ian Lynagh committed
591
  = HsArrApp ...                -- as above
592

Ian Lynagh's avatar
Ian Lynagh committed
593
  | HsArrForm ...               -- as above
594

Ian Lynagh's avatar
Ian Lynagh committed
595
596
  | HsApp       (HsCmd id)
                (HsExpr id)
ross's avatar
ross committed
597

Ian Lynagh's avatar
Ian Lynagh committed
598
  | HsLam       (Match  id)     -- kappa
599
600

  -- the renamer turns this one into HsArrForm
Ian Lynagh's avatar
Ian Lynagh committed
601
602
603
604
  | OpApp       (HsExpr id)     -- left operand
                (HsCmd id)      -- operator
                Fixity          -- Renamer adds fixity; bottom until then
                (HsCmd id)      -- right operand
605

Ian Lynagh's avatar
Ian Lynagh committed
606
  | HsPar       (HsCmd id)      -- parenthesised command
607

Ian Lynagh's avatar
Ian Lynagh committed
608
609
610
  | HsCase      (HsExpr id)
                [Match id]      -- bodies are HsCmd's
                SrcLoc
611

Ian Lynagh's avatar
Ian Lynagh committed
612
613
614
615
  | HsIf        (HsExpr id)     --  predicate
                (HsCmd id)      --  then part
                (HsCmd id)      --  else part
                SrcLoc
616

Ian Lynagh's avatar
Ian Lynagh committed
617
618
  | HsLet       (HsLocalBinds id)       -- let(rec)
                (HsCmd  id)
619

Ian Lynagh's avatar
Ian Lynagh committed
620
621
622
623
624
625
  | 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
626
627
628
629
630
631

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

634
data HsCmdTop id
Ian Lynagh's avatar
Ian Lynagh committed
635
636
637
638
639
  = 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
640
641
\end{code}

642
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
643
%*                                                                      *
644
\subsection{Record binds}
Ian Lynagh's avatar
Ian Lynagh committed
645
%*                                                                      *
646
647
648
%************************************************************************

\begin{code}
649
type HsRecordBinds id = HsRecFields id (LHsExpr id)
650
651
\end{code}

652
653


654
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
655
%*                                                                      *
656
\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
Ian Lynagh's avatar
Ian Lynagh committed
657
%*                                                                      *
658
659
%************************************************************************

660
661
662
663
664
665
666
667
668
669
670
671
672
673
@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.

674
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
675
676
677
678
679
680
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
681

682
683
type LMatch id = Located (Match id)

684
data Match id
685
  = Match
Ian Lynagh's avatar
Ian Lynagh committed
686
687
688
689
        [LPat id]               -- The patterns
        (Maybe (LHsType id))    -- A type signature for the result of the match
                                -- Nothing after typechecking
        (GRHSs id)
690

691
692
693
isEmptyMatchGroup :: MatchGroup id -> Bool
isEmptyMatchGroup (MatchGroup ms _) = null ms

694
matchGroupArity :: MatchGroup id -> Arity
Ian Lynagh's avatar
Ian Lynagh committed
695
matchGroupArity (MatchGroup [] _)
696
  = panic "matchGroupArity"     -- Precondition: MatchGroup is non-empty
697
698
matchGroupArity (MatchGroup (match:matches) _)
  = ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
Ian Lynagh's avatar
Ian Lynagh committed
699
    -- Assertion just checks that all the matches have the same number of pats
700
701
702
703
    n_pats
  where
    n_pats = length (hsLMatchPats match)

704
705
706
hsLMatchPats :: LMatch id -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats

707
-- | GRHSs are used both for pattern bindings and for Matches
Ian Lynagh's avatar
Ian Lynagh committed
708
data GRHSs id
709
710
711
712
  = GRHSs {
      grhssGRHSs :: [LGRHS id],  -- ^ Guarded RHSs
      grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause
    }
713

714
type LGRHS id = Located (GRHS id)
715

716
-- | Guarded Right Hand Side.
Ian Lynagh's avatar
Ian Lynagh committed
717
718
data GRHS id = GRHS [LStmt id]   -- Guards
                    (LHsExpr id) -- Right hand side
719
\end{code}
720

721
We know the list must have at least one @Match@ in it.
722

723
\begin{code}
724
pprMatches :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> MatchGroup idR -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
725
726
pprMatches ctxt (MatchGroup matches _)
    = vcat (map (pprMatch ctxt) (map unLoc matches))
Ian Lynagh's avatar
Ian Lynagh committed
727
      -- Don't print the type; it's only a place-holder before typechecking
728
729

-- Exported to HsBinds, which can't see the defn of HsMatchContext
730
pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => idL -> Bool -> MatchGroup idR -> SDoc
731
pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
732
733

-- Exported to HsBinds, which can't see the defn of HsMatchContext
734
pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
Ian Lynagh's avatar
Ian Lynagh committed
735
           => LPat bndr -> GRHSs id -> SDoc
736
737
738
739
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
740
741


742
pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc
743
pprMatch ctxt (Match pats maybe_ty grhss)
Ian Lynagh's avatar
Ian Lynagh committed
744
745
746
  = herald <+> sep [sep (map ppr other_pats),
                    ppr_maybe_ty,
                    nest 2 (pprGRHSs ctxt grhss)]
747
  where
Ian Lynagh's avatar
Ian Lynagh committed
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
    (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)
767

768
    ppr_maybe_ty = case maybe_ty of
Ian Lynagh's avatar
Ian Lynagh committed
769
770
                        Just ty -> dcolon <+> ppr ty
                        Nothing -> empty
771
772


Ian Lynagh's avatar
Ian Lynagh committed
773
774
pprGRHSs :: (OutputableBndr idL, OutputableBndr idR)
         => HsMatchContext idL -> GRHSs idR -> SDoc
775
pprGRHSs ctxt (GRHSs grhss binds)
Ian Lynagh's avatar
Ian Lynagh committed
776
777
778
  = vcat (map (pprGRHS ctxt . unLoc) grhss)
 $$ if isEmptyLocalBinds binds then empty
                               else text "where" $$ nest 4 (pprBinds binds)
779

Ian Lynagh's avatar
Ian Lynagh committed
780
781
pprGRHS :: (OutputableBndr idL, OutputableBndr idR)
        => HsMatchContext idL -> GRHS idR -> SDoc
782

783
pprGRHS ctxt (GRHS [] expr)
784
 =  pp_rhs ctxt expr
785

786
pprGRHS ctxt (GRHS guards expr)
787
 = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
788

Ian Lynagh's avatar
Ian Lynagh committed
789
pp_rhs :: OutputableBndr idR => HsMatchContext idL -> LHsExpr idR -> SDoc
790
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
791
\end{code}
792

793
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
794
%*                                                                      *
795
\subsection{Do stmts and list comprehensions}
Ian Lynagh's avatar
Ian Lynagh committed
796
%*                                                                      *
797
798
799
%************************************************************************

\begin{code}
800
801
802
803
type LStmt id = Located (StmtLR id id)
type LStmtLR idL idR = Located (StmtLR idL idR)

type Stmt id = StmtLR id id
804

Ian Lynagh's avatar
Ian Lynagh committed
805
806
807
808
809
810
811
812
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
813

814
815
-- The SyntaxExprs in here are used *only* for do-notation, which
-- has rebindable syntax.  Otherwise they are unused.
816
data StmtLR idL idR
Ian Lynagh's avatar
Ian Lynagh committed
817
818
819
820
821
822
  = 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
823

Ian Lynagh's avatar
Ian Lynagh committed
824
825
826
  | ExprStmt (LHsExpr idR)
             (SyntaxExpr idR) -- The (>>) operator
             PostTcType       -- Element type of the RHS (used for arrows)
827

Ian Lynagh's avatar
Ian Lynagh committed
828
  | LetStmt  (HsLocalBindsLR idL idR)
829

Ian Lynagh's avatar
Ian Lynagh committed
830
831
832
833
  -- 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
834
835

  | TransformStmt ([LStmt idL], [idR]) (LHsExpr idR) (Maybe (LHsExpr idR))
Ian Lynagh's avatar
Ian Lynagh committed
836
837
838
839
  -- 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
840
841

  | GroupStmt ([LStmt idL], [(idR, idR)]) (GroupByClause idR)
Ian Lynagh's avatar
Ian Lynagh committed
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
  -- 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
867
868
\end{code}

869
ExprStmts are a bit tricky, because what they mean
870
depends on the context.  Consider the following contexts:
871

Ian Lynagh's avatar
Ian Lynagh committed
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
        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
892
Array comprehensions are handled like list comprehensions -=chak
893

894
895
896
Note [RecStmt]
~~~~~~~~~~~~~~
Example:
Ian Lynagh's avatar
Ian Lynagh committed
897
        HsDo [ BindStmt x ex
898

Ian Lynagh's avatar
Ian Lynagh committed
899
900
901
902
903
             , RecStmt [a::forall a. a -> a, b]
                       [a::Int -> Int,       c]
                       [ BindStmt b (return x)
                       , LetStmt a = ea
                       , BindStmt c ec ]
904

Ian Lynagh's avatar
Ian Lynagh committed
905
             , return (a b) ]
906

Ian Lynagh's avatar
Ian Lynagh committed
907
908
909
Here, the RecStmt binds a,b,c; but
  - Only a,b are used in the stmts *following* the RecStmt,
        This 'a' is *polymorphic'
910
  - Only a,c are used in the stmts *inside* the RecStmt
Ian Lynagh's avatar
Ian Lynagh committed
911
912
        *before* their bindings
        This 'a' is monomorphic
913
914
915
916
917

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


918
\begin{code}
919
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where
920
921
    ppr stmt = pprStmt stmt

922
pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
923
924
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
925
926
pprStmt (ExprStmt expr _ _)       = ppr expr
pprStmt (ParStmt stmtss)          = hsep (map doStmts stmtss)
Ian Lynagh's avatar
Ian Lynagh committed
927
  where doStmts stmts = ptext (sLit "| ") <> ppr stmts
Ian Lynagh's avatar
Ian Lynagh committed
928
pprStmt (TransformStmt (stmts, _) usingExpr maybeByExpr)
Ian Lynagh's avatar
Ian Lynagh committed
929
    = (hsep [stmtsDoc, ptext (sLit "then"), ppr usingExpr, byExprDoc])
930
  where stmtsDoc = interpp'SP stmts
Ian Lynagh's avatar
Ian Lynagh committed
931
932
        byExprDoc = maybe empty (\byExpr -> hsep [ptext (sLit "by"), ppr byExpr]) maybeByExpr
pprStmt (GroupStmt (stmts, _) groupByClause) = (hsep [stmtsDoc, ptext (sLit "then group"), pprGroupByClause groupByClause])
933
  where stmtsDoc = interpp'SP stmts
Ian Lynagh's avatar
Ian Lynagh committed
934
pprStmt (RecStmt segment _ _ _ _) = ptext (sLit "rec") <+> braces (vcat (map ppr segment))
935

936
pprGroupByClause :: (OutputableBndr id) => GroupByClause id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
937
938
939
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
940

941
pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
942
943
pprDo DoExpr      stmts body = ptext (sLit "do")  <+> ppr_do_stmts stmts body
pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body
944
945
pprDo ListComp    stmts body = pprComp brackets    stmts body
pprDo PArrComp    stmts body = pprComp pa_brackets stmts body
Ian Lynagh's avatar
Ian Lynagh committed
946
pprDo _           _     _    = panic "pprDo" -- PatGuard, ParStmtCxt
947

948
949
950
951
952
953
954
ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
-- Print a bunch of do stmts, with explicit braces and semicolons,
-- so that we are not vulnerable to layout bugs
ppr_do_stmts stmts body
  = lbrace <+> pprDeeperList vcat ([ ppr s <> semi | s <- stmts] ++ [ppr body])
           <+> rbrace

955
956
pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc
pprComp brack quals body
957
  = brack $
Ian Lynagh's avatar
Ian Lynagh committed
958
959
        hang (ppr body <+> char '|')
             4 (interpp'SP quals)
960
961
\end{code}

962
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
963
964
965
%*                                                                      *
                Template Haskell quotation brackets
%*                                                                      *
966
967
968
%************************************************************************

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

973
974
975
976
instance OutputableBndr id => Outputable (HsSplice id) where
  ppr = pprSplice

pprSplice :: OutputableBndr id => HsSplice id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
977
978
pprSplice (HsSplice n e)
    = char '$' <> ifPprDebug (brackets (ppr n)) <> pprParendExpr e
979
980


Ian Lynagh's avatar
Ian Lynagh committed
981
982
983
984
985
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
986
987
988
989
990

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


Ian Lynagh's avatar
Ian Lynagh committed
991
pprHsBracket :: OutputableBndr id => HsBracket id -> SDoc
992
993
pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
994
pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d)
995
pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
996
pprHsBracket (VarBr n) = char '\'' <> ppr n
Ian Lynagh's avatar
Ian Lynagh committed
997
998
999
1000
-- 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
1001

Ian Lynagh's avatar
Ian Lynagh committed
1002
thBrackets :: SDoc -> SDoc -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
1003
thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
Ian Lynagh's avatar
Ian Lynagh committed
1004
                             pp_body <+> ptext (sLit "|]")
1005
1006
\end{code}

1007
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
1008
%*                                                                      *
1009
\subsection{Enumerations and list comprehensions}
Ian Lynagh's avatar
Ian Lynagh committed
1010
%*                                                                      *
1011
1012
1013
%************************************************************************

\begin{code}
1014
data ArithSeqInfo id
Ian Lynagh's avatar
Ian Lynagh committed
1015
1016
1017
1018
1019
1020
1021
1022
  = From            (LHsExpr id)
  | FromThen        (LHsExpr id)
                    (LHsExpr id)
  | FromTo          (LHsExpr id)
                    (LHsExpr id)
  | FromThenTo      (LHsExpr id)
                    (LHsExpr id)
                    (LHsExpr id)
1023
1024
1025
\end{code}

\begin{code}
1026
instance OutputableBndr id => Outputable (ArithSeqInfo id) where
Ian Lynagh's avatar
Ian Lynagh committed
1027
1028
1029
    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]
1030
1031
    ppr (FromThenTo e1 e2 e3)
      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]
1032

Ian Lynagh's avatar
Ian Lynagh committed
1033
pp_dotdot :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
1034
pp_dotdot = ptext (sLit " .. ")