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