compiler/deSugar/DsExpr.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Desugaring exporessions.
   7
   8 \begin{code}
   9 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
  10
  11 #include "HsVersions.h"
  12
  13
  14 import Match
  15 import MatchLit
  16 import DsBinds
  17 import DsGRHSs
  18 import DsListComp
  19 import DsUtils
  20 import DsArrows
  21 import DsMonad
  22
  23 #ifdef GHCI
  24 import PrelNames
  25         -- Template Haskell stuff iff bootstrapped
  26 import DsMeta
  27 #endif
  28
  29 import HsSyn
  30 import TcHsSyn
  31
  32 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
  33 --     needs to see source types
  34 import TcType
  35 import Type
  36 import CoreSyn
  37 import CoreUtils
  38
  39 import CostCentre
  40 import Id
  41 import PrelInfo
  42 import DataCon
  43 import TyCon
  44 import TysWiredIn
  45 import BasicTypes
  46 import PrelNames
  47 import SrcLoc
  48 import Util
  49 import Bag
  50 import Outputable
  51 import FastString
  52 \end{code}
  53
  54
  55 %************************************************************************
  56 %*                                                                      *
  57                 dsLocalBinds, dsValBinds
  58 %*                                                                      *
  59 %************************************************************************
  60
  61 \begin{code}
  62 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
  63 dsLocalBinds EmptyLocalBinds    body = return body
  64 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
  65 dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body
  66
  67 -------------------------
  68 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
  69 dsValBinds (ValBindsOut binds _) body = foldrDs ds_val_bind body binds
  70
  71 -------------------------
  72 dsIPBinds (IPBinds ip_binds dict_binds) body
  73   = do  { prs <- dsLHsBinds dict_binds
  74         ; let inner = Let (Rec prs) body
  75                 -- The dict bindings may not be in
  76                 -- dependency order; hence Rec
  77         ; foldrDs ds_ip_bind inner ip_binds }
  78   where
  79     ds_ip_bind (L _ (IPBind n e)) body
  80       = dsLExpr e       `thenDs` \ e' ->
  81         returnDs (Let (NonRec (ipNameName n) e') body)
  82
  83 -------------------------
  84 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
  85 -- Special case for bindings which bind unlifted variables
  86 -- We need to do a case right away, rather than building
  87 -- a tuple and doing selections.
  88 -- Silently ignore INLINE and SPECIALISE pragmas...
  89 ds_val_bind (NonRecursive, hsbinds) body
  90   | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
  91     (L loc bind : null_binds) <- bagToList binds,
  92     isBangHsBind bind
  93     || isUnboxedTupleBind bind
  94     || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
  95   = let
  96       body_w_exports                  = foldr bind_export body exports
  97       bind_export (tvs, g, l, _) body = ASSERT( null tvs )
  98                                         bindNonRec g (Var l) body
  99     in
 100     ASSERT (null null_binds)
 101         -- Non-recursive, non-overloaded bindings only come in ones
 102         -- ToDo: in some bizarre case it's conceivable that there
 103         --       could be dict binds in the 'binds'.  (See the notes
 104         --       below.  Then pattern-match would fail.  Urk.)
 105     putSrcSpanDs loc    $
 106     case bind of
 107       FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick }
 108         -> matchWrapper (FunRhs (idName fun)) matches           `thenDs` \ (args, rhs) ->
 109            ASSERT( null args )  -- Functions aren't lifted
 110            ASSERT( isIdHsWrapper co_fn )
 111            mkOptTickBox tick rhs                                `thenDs` \ rhs' ->
 112            returnDs (bindNonRec fun rhs' body_w_exports)
 113
 114       PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
 115         ->      -- let C x# y# = rhs in body
 116                 -- ==> case rhs of C x# y# -> body
 117            putSrcSpanDs loc                     $
 118            do { rhs <- dsGuarded grhss ty
 119               ; let upat = unLoc pat
 120                     eqn = EqnInfo { eqn_pats = [upat],
 121                                     eqn_rhs = cantFailMatchResult body_w_exports }
 122               ; var    <- selectMatchVar upat
 123               ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
 124               ; return (scrungleMatch var rhs result) }
 125
 126       other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
 127
 128
 129 -- Ordinary case for bindings; none should be unlifted
 130 ds_val_bind (is_rec, binds) body
 131   = do  { prs <- dsLHsBinds binds
 132         ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
 133           case prs of
 134             []    -> return body
 135             other -> return (Let (Rec prs) body) }
 136         -- Use a Rec regardless of is_rec.
 137         -- Why? Because it allows the binds to be all
 138         -- mixed up, which is what happens in one rare case
 139         -- Namely, for an AbsBind with no tyvars and no dicts,
 140         --         but which does have dictionary bindings.
 141         -- See notes with TcSimplify.inferLoop [NO TYVARS]
 142         -- It turned out that wrapping a Rec here was the easiest solution
 143         --
 144         -- NB The previous case dealt with unlifted bindings, so we
 145         --    only have to deal with lifted ones now; so Rec is ok
 146
 147 isUnboxedTupleBind :: HsBind Id -> Bool
 148 isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
 149 isUnboxedTupleBind other                         = False
 150
 151 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 152 -- Returns something like (let var = scrut in body)
 153 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
 154 -- Special case to handle unboxed tuple patterns; they can't appear nested
 155 -- The idea is that
 156 --      case e of (# p1, p2 #) -> rhs
 157 -- should desugar to
 158 --      case e of (# x1, x2 #) -> ... match p1, p2 ...
 159 -- NOT
 160 --      let x = e in case x of ....
 161 --
 162 -- But there may be a big
 163 --      let fail = ... in case e of ...
 164 -- wrapping the whole case, which complicates matters slightly
 165 -- It all seems a bit fragile.  Test is dsrun013.
 166
 167 scrungleMatch var scrut body
 168   | isUnboxedTupleType (idType var) = scrungle body
 169   | otherwise                       = bindNonRec var scrut body
 170   where
 171     scrungle (Case (Var x) bndr ty alts)
 172                     | x == var = Case scrut bndr ty alts
 173     scrungle (Let binds body)  = Let binds (scrungle body)
 174     scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
 175
 176 \end{code}
 177
 178 %************************************************************************
 179 %*                                                                      *
 180 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
 181 %*                                                                      *
 182 %************************************************************************
 183
 184 \begin{code}
 185 dsLExpr :: LHsExpr Id -> DsM CoreExpr
 186
 187 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
 188
 189 dsExpr :: HsExpr Id -> DsM CoreExpr
 190 dsExpr (HsPar e)              = dsLExpr e
 191 dsExpr (ExprWithTySigOut e _) = dsLExpr e
 192 dsExpr (HsVar var)            = returnDs (Var var)
 193 dsExpr (HsIPVar ip)           = returnDs (Var (ipNameName ip))
 194 dsExpr (HsLit lit)            = dsLit lit
 195 dsExpr (HsOverLit lit)        = dsOverLit lit
 196 dsExpr (HsWrap co_fn e)       = dsCoercion co_fn (dsExpr e)
 197
 198 dsExpr (NegApp expr neg_expr)
 199   = do  { core_expr <- dsLExpr expr
 200         ; core_neg  <- dsExpr neg_expr
 201         ; return (core_neg `App` core_expr) }
 202
 203 dsExpr expr@(HsLam a_Match)
 204   = matchWrapper LambdaExpr a_Match     `thenDs` \ (binders, matching_code) ->
 205     returnDs (mkLams binders matching_code)
 206
 207 dsExpr expr@(HsApp fun arg)
 208   = dsLExpr fun         `thenDs` \ core_fun ->
 209     dsLExpr arg         `thenDs` \ core_arg ->
 210     returnDs (core_fun `mkDsApp` core_arg)
 211 \end{code}
 212
 213 Operator sections.  At first it looks as if we can convert
 214 \begin{verbatim}
 215         (expr op)
 216 \end{verbatim}
 217 to
 218 \begin{verbatim}
 219         \x -> op expr x
 220 \end{verbatim}
 221
 222 But no!  expr might be a redex, and we can lose laziness badly this
 223 way.  Consider
 224 \begin{verbatim}
 225         map (expr op) xs
 226 \end{verbatim}
 227 for example.  So we convert instead to
 228 \begin{verbatim}
 229         let y = expr in \x -> op y x
 230 \end{verbatim}
 231 If \tr{expr} is actually just a variable, say, then the simplifier
 232 will sort it out.
 233
 234 \begin{code}
 235 dsExpr (OpApp e1 op _ e2)
 236   = dsLExpr op                                          `thenDs` \ core_op ->
 237     -- for the type of y, we need the type of op's 2nd argument
 238     dsLExpr e1                          `thenDs` \ x_core ->
 239     dsLExpr e2                          `thenDs` \ y_core ->
 240     returnDs (mkDsApps core_op [x_core, y_core])
 241
 242 dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
 243   = dsLExpr op                          `thenDs` \ core_op ->
 244     dsLExpr expr                        `thenDs` \ x_core ->
 245     returnDs (mkDsApp core_op x_core)
 246
 247 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
 248 dsExpr (SectionR op expr)
 249   = dsLExpr op                  `thenDs` \ core_op ->
 250     -- for the type of x, we need the type of op's 2nd argument
 251     let
 252         (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
 253         -- See comment with SectionL
 254     in
 255     dsLExpr expr                                `thenDs` \ y_core ->
 256     newSysLocalDs x_ty                  `thenDs` \ x_id ->
 257     newSysLocalDs y_ty                  `thenDs` \ y_id ->
 258
 259     returnDs (bindNonRec y_id y_core $
 260               Lam x_id (mkDsApps core_op [Var x_id, Var y_id]))
 261
 262 dsExpr (HsSCC cc expr)
 263   = dsLExpr expr                        `thenDs` \ core_expr ->
 264     getModuleDs                 `thenDs` \ mod_name ->
 265     returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr)
 266
 267
 268 -- hdaume: core annotation
 269
 270 dsExpr (HsCoreAnn fs expr)
 271   = dsLExpr expr        `thenDs` \ core_expr ->
 272     returnDs (Note (CoreNote $ unpackFS fs) core_expr)
 273
 274 dsExpr (HsCase discrim matches)
 275   = dsLExpr discrim                     `thenDs` \ core_discrim ->
 276     matchWrapper CaseAlt matches        `thenDs` \ ([discrim_var], matching_code) ->
 277     returnDs (scrungleMatch discrim_var core_discrim matching_code)
 278
 279 -- Pepe: The binds are in scope in the body but NOT in the binding group
 280 --       This is to avoid silliness in breakpoints
 281 dsExpr (HsLet binds body)
 282   = dsLExpr body `thenDs` \ body' ->
 283     dsLocalBinds binds body'
 284
 285 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
 286 -- because the interpretation of `stmts' depends on what sort of thing it is.
 287 --
 288 dsExpr (HsDo ListComp stmts body result_ty)
 289   =     -- Special case for list comprehensions
 290     dsListComp stmts body elt_ty
 291   where
 292     [elt_ty] = tcTyConAppArgs result_ty
 293
 294 dsExpr (HsDo DoExpr stmts body result_ty)
 295   = dsDo stmts body result_ty
 296
 297 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
 298   = dsMDo tbl stmts body result_ty
 299
 300 dsExpr (HsDo PArrComp stmts body result_ty)
 301   =     -- Special case for array comprehensions
 302     dsPArrComp (map unLoc stmts) body elt_ty
 303   where
 304     [elt_ty] = tcTyConAppArgs result_ty
 305
 306 dsExpr (HsIf guard_expr then_expr else_expr)
 307   = dsLExpr guard_expr  `thenDs` \ core_guard ->
 308     dsLExpr then_expr   `thenDs` \ core_then ->
 309     dsLExpr else_expr   `thenDs` \ core_else ->
 310     returnDs (mkIfThenElse core_guard core_then core_else)
 311 \end{code}
 312
 313
 314 \noindent
 315 \underline{\bf Various data construction things}
 316 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 317 \begin{code}
 318 dsExpr (ExplicitList ty xs)
 319   = go xs
 320   where
 321     go []     = returnDs (mkNilExpr ty)
 322     go (x:xs) = dsLExpr x                               `thenDs` \ core_x ->
 323                 go xs                                   `thenDs` \ core_xs ->
 324                 returnDs (mkConsExpr ty core_x core_xs)
 325
 326 -- we create a list from the array elements and convert them into a list using
 327 -- `PrelPArr.toP'
 328 --
 329 --  * the main disadvantage to this scheme is that `toP' traverses the list
 330 --   twice: once to determine the length and a second time to put to elements
 331 --   into the array; this inefficiency could be avoided by exposing some of
 332 --   the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so
 333 --   that we can exploit the fact that we already know the length of the array
 334 --   here at compile time
 335 --
 336 dsExpr (ExplicitPArr ty xs)
 337   = dsLookupGlobalId toPName                            `thenDs` \toP      ->
 338     dsExpr (ExplicitList ty xs)                         `thenDs` \coreList ->
 339     returnDs (mkApps (Var toP) [Type ty, coreList])
 340
 341 dsExpr (ExplicitTuple expr_list boxity)
 342   = mappM dsLExpr expr_list       `thenDs` \ core_exprs  ->
 343     returnDs (mkConApp (tupleCon boxity (length expr_list))
 344                        (map (Type .  exprType) core_exprs ++ core_exprs))
 345
 346 dsExpr (ArithSeq expr (From from))
 347   = dsExpr expr           `thenDs` \ expr2 ->
 348     dsLExpr from          `thenDs` \ from2 ->
 349     returnDs (App expr2 from2)
 350
 351 dsExpr (ArithSeq expr (FromTo from two))
 352   = dsExpr expr           `thenDs` \ expr2 ->
 353     dsLExpr from          `thenDs` \ from2 ->
 354     dsLExpr two           `thenDs` \ two2 ->
 355     returnDs (mkApps expr2 [from2, two2])
 356
 357 dsExpr (ArithSeq expr (FromThen from thn))
 358   = dsExpr expr           `thenDs` \ expr2 ->
 359     dsLExpr from          `thenDs` \ from2 ->
 360     dsLExpr thn           `thenDs` \ thn2 ->
 361     returnDs (mkApps expr2 [from2, thn2])
 362
 363 dsExpr (ArithSeq expr (FromThenTo from thn two))
 364   = dsExpr expr           `thenDs` \ expr2 ->
 365     dsLExpr from          `thenDs` \ from2 ->
 366     dsLExpr thn           `thenDs` \ thn2 ->
 367     dsLExpr two           `thenDs` \ two2 ->
 368     returnDs (mkApps expr2 [from2, thn2, two2])
 369
 370 dsExpr (PArrSeq expr (FromTo from two))
 371   = dsExpr expr           `thenDs` \ expr2 ->
 372     dsLExpr from          `thenDs` \ from2 ->
 373     dsLExpr two           `thenDs` \ two2 ->
 374     returnDs (mkApps expr2 [from2, two2])
 375
 376 dsExpr (PArrSeq expr (FromThenTo from thn two))
 377   = dsExpr expr           `thenDs` \ expr2 ->
 378     dsLExpr from          `thenDs` \ from2 ->
 379     dsLExpr thn           `thenDs` \ thn2 ->
 380     dsLExpr two           `thenDs` \ two2 ->
 381     returnDs (mkApps expr2 [from2, thn2, two2])
 382
 383 dsExpr (PArrSeq expr _)
 384   = panic "DsExpr.dsExpr: Infinite parallel array!"
 385     -- the parser shouldn't have generated it and the renamer and typechecker
 386     -- shouldn't have let it through
 387 \end{code}
 388
 389 \noindent
 390 \underline{\bf Record construction and update}
 391 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 392 For record construction we do this (assuming T has three arguments)
 393 \begin{verbatim}
 394         T { op2 = e }
 395 ==>
 396         let err = /\a -> recConErr a
 397         T (recConErr t1 "M.lhs/230/op1")
 398           e
 399           (recConErr t1 "M.lhs/230/op3")
 400 \end{verbatim}
 401 @recConErr@ then converts its arugment string into a proper message
 402 before printing it as
 403 \begin{verbatim}
 404         M.lhs, line 230: missing field op1 was evaluated
 405 \end{verbatim}
 406
 407 We also handle @C{}@ as valid construction syntax for an unlabelled
 408 constructor @C@, setting all of @C@'s fields to bottom.
 409
 410 \begin{code}
 411 dsExpr (RecordCon (L _ data_con_id) con_expr (HsRecordBinds rbinds))
 412   = dsExpr con_expr     `thenDs` \ con_expr' ->
 413     let
 414         (arg_tys, _) = tcSplitFunTys (exprType con_expr')
 415         -- A newtype in the corner should be opaque;
 416         -- hence TcType.tcSplitFunTys
 417
 418         mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
 419           = case [rhs | (L _ sel_id, rhs) <- rbinds, lbl == idName sel_id] of
 420               (rhs:rhss) -> ASSERT( null rhss )
 421                             dsLExpr rhs
 422               []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
 423         unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
 424
 425         labels = dataConFieldLabels (idDataCon data_con_id)
 426         -- The data_con_id is guaranteed to be the wrapper id of the constructor
 427     in
 428
 429     (if null labels
 430         then mappM unlabelled_bottom arg_tys
 431         else mappM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels))
 432         `thenDs` \ con_args ->
 433
 434     returnDs (mkApps con_expr' con_args)
 435 \end{code}
 436
 437 Record update is a little harder. Suppose we have the decl:
 438 \begin{verbatim}
 439         data T = T1 {op1, op2, op3 :: Int}
 440                | T2 {op4, op2 :: Int}
 441                | T3
 442 \end{verbatim}
 443 Then we translate as follows:
 444 \begin{verbatim}
 445         r { op2 = e }
 446 ===>
 447         let op2 = e in
 448         case r of
 449           T1 op1 _ op3 -> T1 op1 op2 op3
 450           T2 op4 _     -> T2 op4 op2
 451           other        -> recUpdError "M.lhs/230"
 452 \end{verbatim}
 453 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
 454 RHSs, and do not generate a Core constructor application directly, because the constructor
 455 might do some argument-evaluation first; and may have to throw away some
 456 dictionaries.
 457
 458 \begin{code}
 459 dsExpr (RecordUpd record_expr (HsRecordBinds []) record_in_ty record_out_ty)
 460   = dsLExpr record_expr
 461
 462 dsExpr expr@(RecordUpd record_expr (HsRecordBinds rbinds) record_in_ty record_out_ty)
 463   = dsLExpr record_expr         `thenDs` \ record_expr' ->
 464
 465         -- Desugar the rbinds, and generate let-bindings if
 466         -- necessary so that we don't lose sharing
 467
 468     let
 469         in_inst_tys  = tcTyConAppArgs record_in_ty      -- Newtype opaque
 470         out_inst_tys = tcTyConAppArgs record_out_ty     -- Newtype opaque
 471         in_out_ty    = mkFunTy record_in_ty record_out_ty
 472
 473         mk_val_arg field old_arg_id
 474           = case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of
 475               (rhs:rest) -> ASSERT(null rest) rhs
 476               []         -> nlHsVar old_arg_id
 477
 478         mk_alt con
 479           = ASSERT( isVanillaDataCon con )
 480             newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids ->
 481                 -- This call to dataConInstOrigArgTys won't work for existentials
 482                 -- but existentials don't have record types anyway
 483             let
 484                 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
 485                                         (dataConFieldLabels con) arg_ids
 486                 rhs = foldl (\a b -> nlHsApp a b)
 487                             (nlHsTyApp (dataConWrapId con) out_inst_tys)
 488                             val_args
 489             in
 490             returnDs (mkSimpleMatch [mkPrefixConPat con (map nlVarPat arg_ids) record_in_ty] rhs)
 491     in
 492         -- Record stuff doesn't work for existentials
 493         -- The type checker checks for this, but we need
 494         -- worry only about the constructors that are to be updated
 495     ASSERT2( all isVanillaDataCon cons_to_upd, ppr expr )
 496
 497         -- It's important to generate the match with matchWrapper,
 498         -- and the right hand sides with applications of the wrapper Id
 499         -- so that everything works when we are doing fancy unboxing on the
 500         -- constructor aguments.
 501     mappM mk_alt cons_to_upd                            `thenDs` \ alts ->
 502     matchWrapper RecUpd (MatchGroup alts in_out_ty)     `thenDs` \ ([discrim_var], matching_code) ->
 503
 504     returnDs (bindNonRec discrim_var record_expr' matching_code)
 505
 506   where
 507     updated_fields :: [FieldLabel]
 508     updated_fields = [ idName sel_id | (L _ sel_id,_) <- rbinds]
 509
 510         -- Get the type constructor from the record_in_ty
 511         -- so that we are sure it'll have all its DataCons
 512         -- (In GHCI, it's possible that some TyCons may not have all
 513         --  their constructors, in a module-loop situation.)
 514     tycon       = tcTyConAppTyCon record_in_ty
 515     data_cons   = tyConDataCons tycon
 516     cons_to_upd = filter has_all_fields data_cons
 517
 518     has_all_fields :: DataCon -> Bool
 519     has_all_fields con_id
 520       = all (`elem` con_fields) updated_fields
 521       where
 522         con_fields = dataConFieldLabels con_id
 523 \end{code}
 524
 525 Here is where we desugar the Template Haskell brackets and escapes
 526
 527 \begin{code}
 528 -- Template Haskell stuff
 529
 530 #ifdef GHCI     /* Only if bootstrapping */
 531 dsExpr (HsBracketOut x ps) = dsBracket x ps
 532 dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
 533 #endif
 534
 535 -- Arrow notation extension
 536 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
 537 \end{code}
 538
 539 Hpc Support
 540
 541 \begin{code}
 542 dsExpr (HsTick ix vars e) = do
 543   e' <- dsLExpr e
 544   mkTickBox ix vars e'
 545
 546 -- There is a problem here. The then and else branches
 547 -- have no free variables, so they are open to lifting.
 548 -- We need someway of stopping this.
 549 -- This will make no difference to binary coverage
 550 -- (did you go here: YES or NO), but will effect accurate
 551 -- tick counting.
 552
 553 dsExpr (HsBinTick ixT ixF e) = do
 554   e2 <- dsLExpr e
 555   do { ASSERT(exprType e2 `coreEqType` boolTy)
 556        mkBinaryTickBox ixT ixF e2
 557      }
 558 \end{code}
 559
 560 \begin{code}
 561
 562 #ifdef DEBUG
 563 -- HsSyn constructs that just shouldn't be here:
 564 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
 565 #endif
 566
 567 \end{code}
 568
 569 %--------------------------------------------------------------------
 570
 571 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
 572 handled in DsListComp).  Basically does the translation given in the
 573 Haskell 98 report:
 574
 575 \begin{code}
 576 dsDo    :: [LStmt Id]
 577         -> LHsExpr Id
 578         -> Type                 -- Type of the whole expression
 579         -> DsM CoreExpr
 580
 581 dsDo stmts body result_ty
 582   = go (map unLoc stmts)
 583   where
 584     go [] = dsLExpr body
 585
 586     go (ExprStmt rhs then_expr _ : stmts)
 587       = do { rhs2 <- dsLExpr rhs
 588            ; then_expr2 <- dsExpr then_expr
 589            ; rest <- go stmts
 590            ; returnDs (mkApps then_expr2 [rhs2, rest]) }
 591
 592     go (LetStmt binds : stmts)
 593       = do { rest <- go stmts
 594            ; dsLocalBinds binds rest }
 595
 596     go (BindStmt pat rhs bind_op fail_op : stmts)
 597       =
 598        do { body  <- go stmts
 599            ; var   <- selectSimpleMatchVarL pat
 600            ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
 601                                   result_ty (cantFailMatchResult body)
 602            ; match_code <- handle_failure pat match fail_op
 603            ; rhs'       <- dsLExpr rhs
 604            ; bind_op'   <- dsExpr bind_op
 605            ; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
 606
 607     -- In a do expression, pattern-match failure just calls
 608     -- the monadic 'fail' rather than throwing an exception
 609     handle_failure pat match fail_op
 610       | matchCanFail match
 611       = do { fail_op' <- dsExpr fail_op
 612            ; fail_msg <- mkStringExpr (mk_fail_msg pat)
 613            ; extractMatchResult match (App fail_op' fail_msg) }
 614       | otherwise
 615       = extractMatchResult match (error "It can't fail")
 616
 617 mk_fail_msg pat = "Pattern match failure in do expression at " ++
 618                   showSDoc (ppr (getLoc pat))
 619 \end{code}
 620
 621 Translation for RecStmt's:
 622 -----------------------------
 623 We turn (RecStmt [v1,..vn] stmts) into:
 624
 625   (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
 626                                       return (v1,..vn))
 627
 628 \begin{code}
 629 dsMDo   :: PostTcTable
 630         -> [LStmt Id]
 631         -> LHsExpr Id
 632         -> Type                 -- Type of the whole expression
 633         -> DsM CoreExpr
 634
 635 dsMDo tbl stmts body result_ty
 636   = go (map unLoc stmts)
 637   where
 638     (m_ty, b_ty) = tcSplitAppTy result_ty       -- result_ty must be of the form (m b)
 639     mfix_id   = lookupEvidence tbl mfixName
 640     return_id = lookupEvidence tbl returnMName
 641     bind_id   = lookupEvidence tbl bindMName
 642     then_id   = lookupEvidence tbl thenMName
 643     fail_id   = lookupEvidence tbl failMName
 644     ctxt      = MDoExpr tbl
 645
 646     go [] = dsLExpr body
 647
 648     go (LetStmt binds : stmts)
 649       = do { rest <- go stmts
 650            ; dsLocalBinds binds rest }
 651
 652     go (ExprStmt rhs _ rhs_ty : stmts)
 653       = do { rhs2 <- dsLExpr rhs
 654            ; rest <- go stmts
 655            ; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
 656
 657     go (BindStmt pat rhs _ _ : stmts)
 658       = do { body  <- go stmts
 659            ; var   <- selectSimpleMatchVarL pat
 660            ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
 661                                   result_ty (cantFailMatchResult body)
 662            ; fail_msg   <- mkStringExpr (mk_fail_msg pat)
 663            ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
 664            ; match_code <- extractMatchResult match fail_expr
 665
 666            ; rhs'       <- dsLExpr rhs
 667            ; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
 668                                              rhs', Lam var match_code]) }
 669
 670     go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
 671       = ASSERT( length rec_ids > 0 )
 672         ASSERT( length rec_ids == length rec_rets )
 673         go (new_bind_stmt : let_stmt : stmts)
 674       where
 675         new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
 676         let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
 677
 678
 679                 -- Remove the later_ids that appear (without fancy coercions)
 680                 -- in rec_rets, because there's no need to knot-tie them separately
 681                 -- See Note [RecStmt] in HsExpr
 682         later_ids'   = filter (`notElem` mono_rec_ids) later_ids
 683         mono_rec_ids = [ id | HsVar id <- rec_rets ]
 684
 685         mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
 686         mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
 687                                              (mkFunTy tup_ty body_ty))
 688
 689         -- The rec_tup_pat must bind the rec_ids only; remember that the
 690         --      trimmed_laters may share the same Names
 691         -- Meanwhile, the later_pats must bind the later_vars
 692         rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
 693         later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
 694         rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
 695
 696         mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
 697         body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
 698         body_ty = mkAppTy m_ty tup_ty
 699         tup_ty  = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
 700                   -- mkCoreTupTy deals with singleton case
 701
 702         return_app  = nlHsApp (nlHsTyApp return_id [tup_ty])
 703                               (mk_ret_tup rets)
 704
 705         mk_wild_pat :: Id -> LPat Id
 706         mk_wild_pat v = noLoc $ WildPat $ idType v
 707
 708         mk_later_pat :: Id -> LPat Id
 709         mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
 710                        | otherwise           = nlVarPat v
 711
 712         mk_tup_pat :: [LPat Id] -> LPat Id
 713         mk_tup_pat [p] = p
 714         mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
 715
 716         mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
 717         mk_ret_tup [r] = r
 718         mk_ret_tup rs  = noLoc $ ExplicitTuple rs Boxed
 719 \end{code}