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