HsExpr.lhs 63.3 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

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

255 256 257 258 259
  | HsTcBracketOut
      (HsBracket Name)     -- Output of the type checker is the *original*
                           -- renamed expression, plus
      [PendingTcSplice]    -- _typechecked_ splices to be
                           -- pasted back in by the desugarer
260

261 262
  | HsSpliceE    Bool                   -- True <=> typed splice
                 (HsSplice id)          -- False <=> untyped
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
-- See Note [Pending Splices]
349 350 351 352 353
data PendingRnSplice
  = PendingRnExpSplice        (HsSplice Name)
  | PendingRnPatSplice        (HsSplice Name)
  | PendingRnTypeSplice       (HsSplice Name)
  | PendingRnDeclSplice       (HsSplice Name)
gmainland's avatar
gmainland committed
354 355
  | PendingRnCrossStageSplice Name
  deriving (Data, Typeable)
356 357

type PendingTcSplice = (Name, LHsExpr Id)
358 359
\end{code}

gmainland's avatar
gmainland committed
360 361 362 363 364
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
365
splices that need to be type checked. There are four varieties of pending
gmainland's avatar
gmainland committed
366 367 368 369 370 371
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
 * Pending type splices (PendingRnTypeSplice), e.g.,

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

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

   \x -> [| x |]

384
There is a fifth variety of pending splice, which is generated by the type
gmainland's avatar
gmainland committed
385 386 387 388 389 390 391 392 393 394 395 396 397
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

602 603
ppr_expr (HsSpliceE t s)       = pprSplice t s
ppr_expr (HsBracket b)         = pprHsBracket b
604 605
ppr_expr (HsRnBracketOut e []) = ppr e
ppr_expr (HsRnBracketOut e ps) = ppr e $$ ptext (sLit "pending(rn)") <+> ppr ps
606 607
ppr_expr (HsTcBracketOut e []) = ppr e
ppr_expr (HsTcBracketOut e ps) = ppr e $$ ptext (sLit "pending(tc)") <+> ppr ps
608
ppr_expr (HsQuasiQuoteE qq)    = ppr qq
609

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

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

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

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

649 650
\end{code}

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

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

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

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


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

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

We re-use HsExpr to represent these.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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 846

\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)]

847 848 849
ppr_cmd (HsCmdDo stmts _)  = pprDo ArrowExpr stmts
ppr_cmd (HsCmdCast co cmd) = sep [ ppr_cmd cmd
                                 , ptext (sLit "|>") <+> ppr co ]
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 876

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}

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