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