HsExpr.lhs 52.1 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 #-}
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 22 23
import Var
import Name
import BasicTypes
24
import DataCon
25
import SrcLoc
26
import Util( dropTail )
27
import StaticFlags( opt_PprStyle_Debug )
Ian Lynagh's avatar
Ian Lynagh committed
28
import Outputable
29
import FastString
30 31 32

-- libraries:
import Data.Data hiding (Fixity)
33 34
\end{code}

35

36
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
37
%*                                                                      *
38
\subsection{Expressions proper}
Ian Lynagh's avatar
Ian Lynagh committed
39
%*                                                                      *
40 41 42
%************************************************************************

\begin{code}
43 44
-- * Expressions proper

45 46
type LHsExpr id = Located (HsExpr id)

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

noPostTcExpr :: PostTcExpr
Ian Lynagh's avatar
Ian Lynagh committed
56
noPostTcExpr = HsLit (HsString (fsLit "noPostTcExpr"))
57 58 59 60 61

noPostTcTable :: PostTcTable
noPostTcTable = []

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

type SyntaxExpr id = HsExpr id

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


type SyntaxTable id = [(Name, SyntaxExpr id)]
77 78 79
-- ^ Currently used only for 'CmdTop' (sigh)
--
-- * Before the renamer, this list is 'noSyntaxTable'
80
--
81
-- * After the renamer, it takes the form @[(std_name, HsVar actual_name)]@
82 83
--   For example, for the 'return' op of a monad
--
84 85 86 87 88 89 90
--    * 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
91 92 93 94 95 96

noSyntaxTable :: SyntaxTable id
noSyntaxTable = []


-------------------------
97
-- | A Haskell expression.
98
data HsExpr id
99 100 101
  = HsVar     id                        -- ^ variable
  | HsIPVar   (IPName id)               -- ^ implicit parameter
  | HsOverLit (HsOverLit id)            -- ^ Overloaded literals
102

103
  | HsLit     HsLit                     -- ^ Simple (non-overloaded) literals
104

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

Ian Lynagh's avatar
Ian Lynagh committed
107
  | HsApp     (LHsExpr id) (LHsExpr id) -- Application
108

109
  -- Operator applications:
110 111
  -- NB Bracketed ops such as (+) come out as Vars.

112 113 114
  -- 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
115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
  | 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

130 131 132 133
  | ExplicitTuple		-- Used for explicit tuples and sections thereof
        [HsTupArg id] 
        Boxity

Ian Lynagh's avatar
Ian Lynagh committed
134 135 136
  | HsCase      (LHsExpr id)
                (MatchGroup id)

137 138 139 140
  | HsIf        (Maybe (SyntaxExpr id)) -- cond function
    		       		        -- Nothing => use the built-in 'if'
					-- See Note [Rebindable if]
                (LHsExpr id)    --  predicate
Ian Lynagh's avatar
Ian Lynagh committed
141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169
                (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
                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)
170 171
--		(HsMatchGroup Id)  -- Filled in by the type checker to be 
--				   -- a match that does the job
Ian Lynagh's avatar
Ian Lynagh committed
172
                [DataCon]          -- Filled in by the type checker to the
Thomas Schilling's avatar
Thomas Schilling committed
173
                                   -- _non-empty_ list of DataCons that have
Ian Lynagh's avatar
Ian Lynagh committed
174 175 176 177 178 179 180
                                   -- 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
181
                (LHsExpr id)
Ian Lynagh's avatar
Ian Lynagh committed
182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202
                (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)

203
  -----------------------------------------------------------
204
  -- MetaHaskell Extensions
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
205

206
  | HsBracket    (HsBracket id)
207

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

Ian Lynagh's avatar
Ian Lynagh committed
214
  | HsSpliceE (HsSplice id)
215

216 217 218
  | HsQuasiQuoteE (HsQuasiQuote id)
	-- See Note [Quasi-quote overview] in TcSplice

219 220 221
  -----------------------------------------------------------
  -- Arrow notation extension

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
238 239 240 241 242 243 244
  | 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
245

246

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
247 248 249
  ---------------------------------------
  -- Haskell program coverage (Hpc) Support

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

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

Ian Lynagh's avatar
Ian Lynagh committed
260 261 262
  | 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
263 264 265 266

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

Ian Lynagh's avatar
Ian Lynagh committed
268
  | EWildPat                 -- wildcard
269

Ian Lynagh's avatar
Ian Lynagh committed
270 271
  | EAsPat      (Located id) -- as pattern
                (LHsExpr id)
272

Ian Lynagh's avatar
Ian Lynagh committed
273 274
  | EViewPat    (LHsExpr id) -- view pattern
                (LHsExpr id)
275

Ian Lynagh's avatar
Ian Lynagh committed
276
  | ELazyPat    (LHsExpr id) -- ~ pattern
277

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

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
280 281
  ---------------------------------------
  -- Finally, HsWrap appears only in typechecker output
282

Ian Lynagh's avatar
Ian Lynagh committed
283 284
  |  HsWrap     HsWrapper    -- TRANSLATION
                (HsExpr id)
285
  deriving (Data, Typeable)
286

287 288 289 290 291 292
-- 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
293
  deriving (Data, Typeable)
294 295 296 297 298

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

Ian Lynagh's avatar
Ian Lynagh committed
299 300
type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be
                                        -- pasted back in by the desugarer
301 302
\end{code}

303 304 305 306 307 308 309 310 311 312 313 314
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?
Because we allow an 'if' to return *unboxed* results, thus 
  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".
315 316

\begin{code}
317
instance OutputableBndr id => Outputable (HsExpr id) where
318
    ppr expr = pprExpr expr
319 320 321
\end{code}

\begin{code}
322
-----------------------
Ian Lynagh's avatar
Ian Lynagh committed
323
-- pprExpr, pprLExpr, pprBinds call pprDeeper;
324 325
-- the underscore versions do not
pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc
326 327 328
pprLExpr (L _ e) = pprExpr e

pprExpr :: OutputableBndr id => HsExpr id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
329 330 331 332 333 334 335 336 337 338 339 340
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
341

Ian Lynagh's avatar
Ian Lynagh committed
342 343
pprBinds :: (OutputableBndr idL, OutputableBndr idR)
         => HsLocalBindsLR idL idR -> SDoc
344
pprBinds b = pprDeeper (ppr b)
345

346
-----------------------
347 348
ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
349

350
ppr_expr :: OutputableBndr id => HsExpr id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
351
ppr_expr (HsVar v)       = pprHsVar v
352
ppr_expr (HsIPVar v)     = ppr v
353 354
ppr_expr (HsLit lit)     = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
Ian Lynagh's avatar
Ian Lynagh committed
355
ppr_expr (HsPar e)       = parens (ppr_lexpr e)
356 357

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

360 361
ppr_expr (HsApp e1 e2)
  = let (fun, args) = collect_args e1 [e2] in
362
    hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))
363
  where
364 365
    collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
    collect_args fun args = (fun, args)
366

Ian Lynagh's avatar
Ian Lynagh committed
367
ppr_expr (OpApp e1 op _ e2)
368
  = case unLoc op of
369
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
370
      _       -> pp_prefixly
371
  where
Ian Lynagh's avatar
Ian Lynagh committed
372
    pp_e1 = pprDebugParendExpr e1   -- In debug mode, add parens
373
    pp_e2 = pprDebugParendExpr e2   -- to make precedence clear
374 375

    pp_prefixly
376
      = hang (ppr op) 2 (sep [pp_e1, pp_e2])
377 378

    pp_infixly v
379
      = sep [nest 2 pp_e1, pprHsInfix v, nest 2 pp_e2]
380

381
ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
382

383
ppr_expr (SectionL expr op)
384
  = case unLoc op of
385
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
386
      _       -> pp_prefixly
387
  where
388
    pp_expr = pprDebugParendExpr expr
389

390
    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
Ian Lynagh's avatar
Ian Lynagh committed
391
                       4 (hsep [pp_expr, ptext (sLit "x_ )")])
392
    pp_infixly v = (sep [pp_expr, pprHsInfix v])
393

394
ppr_expr (SectionR op expr)
395
  = case unLoc op of
396
      HsVar v -> pp_infixly v
Ian Lynagh's avatar
Ian Lynagh committed
397
      _       -> pp_prefixly
398
  where
399
    pp_expr = pprDebugParendExpr expr
400

Ian Lynagh's avatar
Ian Lynagh committed
401
    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")])
Ian Lynagh's avatar
Ian Lynagh committed
402
                       4 ((<>) pp_expr rparen)
403
    pp_infixly v
404
      = (sep [pprHsInfix v, pp_expr])
405

406 407 408 409 410
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
411
    ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
412 413 414 415 416

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

417 418 419 420
--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
421

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

427
ppr_expr (HsIf _ e1 e2 e3)
Ian Lynagh's avatar
Ian Lynagh committed
428
  = sep [hsep [ptext (sLit "if"), nest 2 (ppr e1), ptext (sLit "then")],
Ian Lynagh's avatar
Ian Lynagh committed
429
         nest 4 (ppr e2),
Ian Lynagh's avatar
Ian Lynagh committed
430
         ptext (sLit "else"),
Ian Lynagh's avatar
Ian Lynagh committed
431
         nest 4 (ppr e3)]
432 433

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

438
ppr_expr (HsLet binds expr)
Ian Lynagh's avatar
Ian Lynagh committed
439 440
  = sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
         hang (ptext (sLit "in"))  2 (ppr expr)]
441

442
ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
443

444
ppr_expr (ExplicitList _ exprs)
445
  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
446

chak's avatar
chak committed
447
ppr_expr (ExplicitPArr _ exprs)
448
  = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
chak's avatar
chak committed
449

Ian Lynagh's avatar
Ian Lynagh committed
450
ppr_expr (RecordCon con_id _ rbinds)
451
  = hang (ppr con_id) 2 (ppr rbinds)
452

453
ppr_expr (RecordUpd aexp rbinds _ _ _)
454
  = hang (pprParendExpr aexp) 2 (ppr rbinds)
455 456

ppr_expr (ExprWithTySig expr sig)
457
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
Ian Lynagh's avatar
Ian Lynagh committed
458
         4 (ppr sig)
459 460
ppr_expr (ExprWithTySigOut expr sig)
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
Ian Lynagh's avatar
Ian Lynagh committed
461
         4 (ppr sig)
462

Ian Lynagh's avatar
Ian Lynagh committed
463 464
ppr_expr (ArithSeq _ info) = brackets (ppr info)
ppr_expr (PArrSeq  _ info) = pa_brackets (ppr info)
chak's avatar
chak committed
465

Ian Lynagh's avatar
Ian Lynagh committed
466 467 468
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
469
ppr_expr (EViewPat p e) = ppr p <+> ptext (sLit "->") <+> ppr e
470 471

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

475
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
Ian Lynagh's avatar
Ian Lynagh committed
476
ppr_expr (HsType id)      = ppr id
chak's avatar
chak committed
477

478 479
ppr_expr (HsSpliceE s)       = pprSplice s
ppr_expr (HsBracket b)       = pprHsBracket b
Ian Lynagh's avatar
Ian Lynagh committed
480
ppr_expr (HsBracketOut e []) = ppr e
Ian Lynagh's avatar
Ian Lynagh committed
481
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext (sLit "pending") <+> ppr ps
482
ppr_expr (HsQuasiQuoteE qq)  = ppr qq
483

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

487
ppr_expr (HsTick tickId vars exp)
488 489 490 491 492 493 494
  = pprTicks (ppr exp) $
    hcat [ptext (sLit "tick<"),
    ppr tickId,
    ptext (sLit ">("),
    hsep (map pprHsVar vars),
    ppr exp,
    ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
495
ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
496 497
  = pprTicks (ppr exp) $
    hcat [ptext (sLit "bintick<"),
Ian Lynagh's avatar
Ian Lynagh committed
498
          ppr tickIdTrue,
Ian Lynagh's avatar
Ian Lynagh committed
499
          ptext (sLit ","),
Ian Lynagh's avatar
Ian Lynagh committed
500
          ppr tickIdFalse,
Ian Lynagh's avatar
Ian Lynagh committed
501 502
          ptext (sLit ">("),
          ppr exp,ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
503
ppr_expr (HsTickPragma externalSrcLoc exp)
504 505
  = pprTicks (ppr exp) $
    hcat [ptext (sLit "tickpragma<"),
Ian Lynagh's avatar
Ian Lynagh committed
506
          ppr externalSrcLoc,
Ian Lynagh's avatar
Ian Lynagh committed
507
          ptext (sLit ">("),
Ian Lynagh's avatar
Ian Lynagh committed
508
          ppr exp,
Ian Lynagh's avatar
Ian Lynagh committed
509
          ptext (sLit ")")]
andy@galois.com's avatar
andy@galois.com committed
510

511
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
Ian Lynagh's avatar
Ian Lynagh committed
512
  = hsep [ppr_lexpr arrow, ptext (sLit "-<"), ppr_lexpr arg]
513
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
Ian Lynagh's avatar
Ian Lynagh committed
514
  = hsep [ppr_lexpr arg, ptext (sLit ">-"), ppr_lexpr arrow]
515
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
Ian Lynagh's avatar
Ian Lynagh committed
516
  = hsep [ppr_lexpr arrow, ptext (sLit "-<<"), ppr_lexpr arg]
517
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
Ian Lynagh's avatar
Ian Lynagh committed
518
  = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
519

520
ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
521
  = sep [pprCmdArg (unLoc arg1), hsep [pprHsInfix v, pprCmdArg (unLoc arg2)]]
522
ppr_expr (HsArrForm op _ args)
Ian Lynagh's avatar
Ian Lynagh committed
523 524
  = hang (ptext (sLit "(|") <> ppr_lexpr op)
         4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
525 526

pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
527 528 529 530
pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
  = ppr_lexpr cmd
pprCmdArg (HsCmdTop cmd _ _ _)
  = parens (ppr_lexpr cmd)
531

Ian Lynagh's avatar
Ian Lynagh committed
532 533 534
instance OutputableBndr id => Outputable (HsCmdTop id) where
    ppr = pprCmdArg

chak's avatar
chak committed
535 536
-- add parallel array brackets around a document
--
537
pa_brackets :: SDoc -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
538
pa_brackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
539 540
\end{code}

541 542 543 544 545 546 547 548 549 550
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.

551
\begin{code}
552 553 554 555
pprDebugParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
pprDebugParendExpr expr
  = getPprStyle (\sty ->
    if debugStyle sty then pprParendExpr expr
Ian Lynagh's avatar
Ian Lynagh committed
556 557
                      else pprLExpr      expr)

558
pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
559
pprParendExpr expr
560
  = let
Ian Lynagh's avatar
Ian Lynagh committed
561 562 563
        pp_as_was = pprLExpr expr
        -- Using pprLExpr makes sure that we go 'deeper'
        -- I think that is usually (always?) right
564
    in
565
    case unLoc expr of
566 567 568 569 570 571 572 573 574 575 576 577
      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
578
      HsDo sc _ _
579
       | isListCompExpr sc -> pp_as_was
Ian Lynagh's avatar
Ian Lynagh committed
580
      _                    -> parens pp_as_was
581

Ian Lynagh's avatar
Ian Lynagh committed
582
isAtomicHsExpr :: HsExpr id -> Bool -- A single token
583 584 585 586 587 588
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
589
isAtomicHsExpr _              = False
590 591
\end{code}

592
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
593
%*                                                                      *
594
\subsection{Commands (in arrow abstractions)}
Ian Lynagh's avatar
Ian Lynagh committed
595
%*                                                                      *
596 597 598 599 600 601 602
%************************************************************************

We re-use HsExpr to represent these.

\begin{code}
type HsCmd id = HsExpr id

603 604
type LHsCmd id = LHsExpr id

605
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
606
  deriving (Data, Typeable)
607 608 609 610
\end{code}

The legal constructors for commands are:

Ian Lynagh's avatar
Ian Lynagh committed
611
  = HsArrApp ...                -- as above
612

Ian Lynagh's avatar
Ian Lynagh committed
613
  | HsArrForm ...               -- as above
614

Ian Lynagh's avatar
Ian Lynagh committed
615 616
  | HsApp       (HsCmd id)
                (HsExpr id)
ross's avatar
ross committed
617

Ian Lynagh's avatar
Ian Lynagh committed
618
  | HsLam       (Match  id)     -- kappa
619 620

  -- the renamer turns this one into HsArrForm
Ian Lynagh's avatar
Ian Lynagh committed
621 622 623 624
  | OpApp       (HsExpr id)     -- left operand
                (HsCmd id)      -- operator
                Fixity          -- Renamer adds fixity; bottom until then
                (HsCmd id)      -- right operand
625

Ian Lynagh's avatar
Ian Lynagh committed
626
  | HsPar       (HsCmd id)      -- parenthesised command
627

Ian Lynagh's avatar
Ian Lynagh committed
628 629 630
  | HsCase      (HsExpr id)
                [Match id]      -- bodies are HsCmd's
                SrcLoc
631

632 633
  | HsIf        (Maybe (SyntaxExpr id)) --  cond function
  					 (HsExpr id)     --  predicate
Ian Lynagh's avatar
Ian Lynagh committed
634 635 636
                (HsCmd id)      --  then part
                (HsCmd id)      --  else part
                SrcLoc
637

Ian Lynagh's avatar
Ian Lynagh committed
638 639
  | HsLet       (HsLocalBinds id)       -- let(rec)
                (HsCmd  id)
640

Ian Lynagh's avatar
Ian Lynagh committed
641 642 643 644 645 646
  | 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
647 648 649 650 651 652

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

655
data HsCmdTop id
Ian Lynagh's avatar
Ian Lynagh committed
656 657 658 659 660
  = 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
661
  deriving (Data, Typeable)
662 663
\end{code}

664
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
665
%*                                                                      *
666
\subsection{Record binds}
Ian Lynagh's avatar
Ian Lynagh committed
667
%*                                                                      *
668 669 670
%************************************************************************

\begin{code}
671
type HsRecordBinds id = HsRecFields id (LHsExpr id)
672 673
\end{code}

674 675


676
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
677
%*                                                                      *
678
\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
Ian Lynagh's avatar
Ian Lynagh committed
679
%*                                                                      *
680 681
%************************************************************************

682 683 684 685 686 687 688 689 690 691 692 693 694 695
@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.

696
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
697 698 699 700 701 702
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
703
  deriving (Data, Typeable)
704

705 706
type LMatch id = Located (Match id)

707
data Match id
708
  = Match
Ian Lynagh's avatar
Ian Lynagh committed
709 710 711 712
        [LPat id]               -- The patterns
        (Maybe (LHsType id))    -- A type signature for the result of the match
                                -- Nothing after typechecking
        (GRHSs id)
713
  deriving (Data, Typeable)
714

715 716 717
isEmptyMatchGroup :: MatchGroup id -> Bool
isEmptyMatchGroup (MatchGroup ms _) = null ms

718
matchGroupArity :: MatchGroup id -> Arity
Ian Lynagh's avatar
Ian Lynagh committed
719
matchGroupArity (MatchGroup [] _)
720
  = panic "matchGroupArity"     -- Precondition: MatchGroup is non-empty
721 722
matchGroupArity (MatchGroup (match:matches) _)
  = ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
Ian Lynagh's avatar
Ian Lynagh committed
723
    -- Assertion just checks that all the matches have the same number of pats
724 725 726 727
    n_pats
  where
    n_pats = length (hsLMatchPats match)

728 729 730
hsLMatchPats :: LMatch id -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats

731
-- | GRHSs are used both for pattern bindings and for Matches
Ian Lynagh's avatar
Ian Lynagh committed
732
data GRHSs id
733 734 735
  = GRHSs {
      grhssGRHSs :: [LGRHS id],  -- ^ Guarded RHSs
      grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause
736
    } deriving (Data, Typeable)
737

738
type LGRHS id = Located (GRHS id)
739

740
-- | Guarded Right Hand Side.
Ian Lynagh's avatar
Ian Lynagh committed
741 742
data GRHS id = GRHS [LStmt id]   -- Guards
                    (LHsExpr id) -- Right hand side
743
  deriving (Data, Typeable)
744
\end{code}
745

746
We know the list must have at least one @Match@ in it.
747

748
\begin{code}
749
pprMatches :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> MatchGroup idR -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
750 751
pprMatches ctxt (MatchGroup matches _)
    = vcat (map (pprMatch ctxt) (map unLoc matches))
Ian Lynagh's avatar
Ian Lynagh committed
752
      -- Don't print the type; it's only a place-holder before typechecking
753 754

-- Exported to HsBinds, which can't see the defn of HsMatchContext
755
pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => idL -> Bool -> MatchGroup idR -> SDoc
756
pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
757 758

-- Exported to HsBinds, which can't see the defn of HsMatchContext
759
pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
Ian Lynagh's avatar
Ian Lynagh committed
760
           => LPat bndr -> GRHSs id -> SDoc
761
pprPatBind pat ty@(grhss)
762
 = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs `asTypeOf` idType ty) grhss)]
763 764
--avoid using PatternSignatures for stage1 code portability
 where idType :: GRHSs id -> HsMatchContext id; idType = undefined
765 766


767
pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc
768
pprMatch ctxt (Match pats maybe_ty grhss)
769 770 771
  = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats)
        , nest 2 ppr_maybe_ty
        , nest 2 (pprGRHSs ctxt grhss) ]
772
  where
Ian Lynagh's avatar
Ian Lynagh committed
773 774 775 776 777 778 779 780
    (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

781
                | null pats2 -> (pp_infix, [])
Ian Lynagh's avatar
Ian Lynagh committed
782 783
                        -- x &&& y = e

784
                | otherwise -> (parens pp_infix, pats2)
Ian Lynagh's avatar
Ian Lynagh committed
785 786
                        -- (x &&& y) z = e
                where
787
                  pp_infix = pprParendLPat pat1 <+> ppr fun <+> pprParendLPat pat2
Ian Lynagh's avatar
Ian Lynagh committed
788 789

            LambdaExpr -> (char '\\', pats)
790 791 792
	    
            _  -> ASSERT( null pats1 )
                  (ppr pat1, [])	-- No parens around the single pat
793

794 795
    (pat1:pats1) = pats
    (pat2:pats2) = pats1
796
    ppr_maybe_ty = case maybe_ty of
Ian Lynagh's avatar
Ian Lynagh committed
797 798
                        Just ty -> dcolon <+> ppr ty
                        Nothing -> empty
799 800


Ian Lynagh's avatar
Ian Lynagh committed
801 802
pprGRHSs :: (OutputableBndr idL, OutputableBndr idR)
         => HsMatchContext idL -> GRHSs idR -> SDoc
803
pprGRHSs ctxt (GRHSs grhss binds)
Ian Lynagh's avatar
Ian Lynagh committed
804
  = vcat (map (pprGRHS ctxt . unLoc) grhss)
805 806
 $$ ppUnless (isEmptyLocalBinds binds)
      (text "where" $$ nest 4 (pprBinds binds))
807

Ian Lynagh's avatar
Ian Lynagh committed
808 809
pprGRHS :: (OutputableBndr idL, OutputableBndr idR)
        => HsMatchContext idL -> GRHS idR -> SDoc
810

811
pprGRHS ctxt (GRHS [] expr)
812
 =  pp_rhs ctxt expr
813

814
pprGRHS ctxt (GRHS guards expr)
815
 = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
816

Ian Lynagh's avatar
Ian Lynagh committed
817
pp_rhs :: OutputableBndr idR => HsMatchContext idL -> LHsExpr idR -> SDoc
818
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
819
\end{code}
820

821
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
822
%*                                                                      *
823
\subsection{Do stmts and list comprehensions}
Ian Lynagh's avatar
Ian Lynagh committed
824
%*                                                                      *
825 826 827
%************************************************************************

\begin{code}
828 829 830 831
type LStmt id = Located (StmtLR id id)
type LStmtLR idL idR = Located (StmtLR idL idR)

type Stmt id = StmtLR id id
832

833 834
-- The SyntaxExprs in here are used *only* for do-notation and monad
-- comprehensions, which have rebindable syntax. Otherwise they are unused.
835
data StmtLR idL idR
836 837
  = LastStmt  -- Always the last Stmt in ListComp, MonadComp, PArrComp, 
    	      -- and (after the renamer) DoExpr, MDoExpr
838 839 840
              -- Not used for GhciStmt, PatGuard, which scope over other stuff
               (LHsExpr idR)
               (SyntaxExpr idR)   -- The return operator, used only for MonadComp