ghc/compiler/deSugar/DsExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[DsExpr]{Matching expressions (Exprs)}
   5
   6 \begin{code}
   7 module DsExpr ( dsExpr ) where
   8
   9 #include "HsVersions.h"
  10
  11 import {-# SOURCE #-} DsBinds (dsBinds )
  12
  13 import HsSyn            ( failureFreePat,
  14                           HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
  15                           Stmt(..), DoOrListComp(..), Match(..), HsBinds, HsType, Fixity,
  16                           GRHSsAndBinds
  17                         )
  18 import TcHsSyn          ( TypecheckedHsExpr, TypecheckedHsBinds,
  19                           TypecheckedRecordBinds, TypecheckedPat,
  20                           TypecheckedStmt,
  21                           maybeBoxedPrimType
  22
  23                         )
  24 import CoreSyn
  25
  26 import DsMonad
  27 import DsCCall          ( dsCCall )
  28 import DsHsSyn          ( outPatType )
  29 import DsListComp       ( dsListComp )
  30 import DsUtils          ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtomGivenTy, mkTupleExpr,
  31                           mkErrorAppDs, showForErr, EquationInfo,
  32                           MatchResult, DsCoreArg
  33                         )
  34 import Match            ( matchWrapper )
  35
  36 import CoreUtils        ( coreExprType, substCoreExpr, argToExpr,
  37                           mkCoreIfThenElse, unTagBinders )
  38 import CostCentre       ( mkUserCC )
  39 import FieldLabel       ( fieldLabelType, FieldLabel )
  40 import Id               ( idType, nullIdEnv, addOneToIdEnv,
  41                           dataConTyCon, dataConArgTys, dataConFieldLabels,
  42                           recordSelectorFieldLabel, Id
  43                         )
  44 import Literal          ( mkMachInt, Literal(..) )
  45 import Name             ( Name{--O only-} )
  46 import PrelVals         ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, voidId )
  47 import TyCon            ( isNewTyCon )
  48 import Type             ( splitSigmaTy, splitFunTys, typePrimRep, mkTyConApp,
  49                           splitAlgTyConApp, splitTyConApp_maybe, applyTy,
  50                           splitAppTy, Type
  51                         )
  52 import TysPrim          ( voidTy )
  53 import TysWiredIn       ( mkTupleTy, tupleCon, nilDataCon, consDataCon, listTyCon, mkListTy,
  54                           charDataCon, charTy
  55                         )
  56 import TyVar            ( addToTyVarEnv, GenTyVar{-instance Eq-} )
  57 import Maybes           ( maybeToBool )
  58 import Util             ( zipEqual )
  59 import Outputable
  60
  61 mk_nil_con ty = mkCon nilDataCon [ty] []  -- micro utility...
  62 \end{code}
  63
  64 The funny business to do with variables is that we look them up in the
  65 Id-to-Id and Id-to-Id maps that the monadery is carrying
  66 around; if we get hits, we use the value accordingly.
  67
  68 %************************************************************************
  69 %*                                                                      *
  70 \subsection[DsExpr-vars-and-cons]{Variables and constructors}
  71 %*                                                                      *
  72 %************************************************************************
  73
  74 \begin{code}
  75 dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
  76
  77 dsExpr e@(HsVar var) = dsId var
  78 \end{code}
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection[DsExpr-literals]{Literals}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 We give int/float literals type Integer and Rational, respectively.
  87 The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
  88 around them.
  89
  90 ToDo: put in range checks for when converting "i"
  91 (or should that be in the typechecker?)
  92
  93 For numeric literals, we try to detect there use at a standard type
  94 (Int, Float, etc.) are directly put in the right constructor.
  95 [NB: down with the @App@ conversion.]
  96 Otherwise, we punt, putting in a "NoRep" Core literal (where the
  97 representation decisions are delayed)...
  98
  99 See also below where we look for @DictApps@ for \tr{plusInt}, etc.
 100
 101 \begin{code}
 102 dsExpr (HsLitOut (HsString s) _)
 103   | _NULL_ s
 104   = returnDs (mk_nil_con charTy)
 105
 106   | _LENGTH_ s == 1
 107   = let
 108         the_char = mkCon charDataCon [] [LitArg (MachChar (_HEAD_ s))]
 109         the_nil  = mk_nil_con charTy
 110     in
 111     mkConDs consDataCon [TyArg charTy, VarArg the_char, VarArg the_nil]
 112
 113 -- "_" => build (\ c n -> c 'c' n)      -- LATER
 114
 115 -- "str" ==> build (\ c n -> foldr charTy T c n "str")
 116
 117 {- LATER:
 118 dsExpr (HsLitOut (HsString str) _)
 119   = newTyVarsDs [alphaTyVar]            `thenDs` \ [new_tyvar] ->
 120     let
 121         new_ty = mkTyVarTy new_tyvar
 122     in
 123     newSysLocalsDs [
 124                 charTy `mkFunTy` (new_ty `mkFunTy` new_ty),
 125                 new_ty,
 126                        mkForallTy [alphaTyVar]
 127                                ((charTy `mkFunTy` (alphaTy `mkFunTy` alphaTy))
 128                                         `mkFunTy` (alphaTy `mkFunTy` alphaTy))
 129                 ]                       `thenDs` \ [c,n,g] ->
 130      returnDs (mkBuild charTy new_tyvar c n g (
 131         foldl App
 132           (CoTyApp (CoTyApp (Var foldrId) charTy) new_ty) *** ensure non-prim type ***
 133           [VarArg c,VarArg n,LitArg (NoRepStr str)]))
 134 -}
 135
 136 -- otherwise, leave it as a NoRepStr;
 137 -- the Core-to-STG pass will wrap it in an application of "unpackCStringId".
 138
 139 dsExpr (HsLitOut (HsString str) _)
 140   = returnDs (Lit (NoRepStr str))
 141
 142 dsExpr (HsLitOut (HsLitLit s) ty)
 143   = returnDs ( mkCon data_con [] [LitArg (MachLitLit s kind)] )
 144   where
 145     (data_con, kind)
 146       = case (maybeBoxedPrimType ty) of
 147           Just (boxing_data_con, prim_ty)
 148             -> (boxing_data_con, typePrimRep prim_ty)
 149           Nothing
 150             -> pprPanic "ERROR: ``literal-literal'' not a single-constructor type: "
 151                         (hcat [ptext s, text "; type: ", ppr ty])
 152
 153 dsExpr (HsLitOut (HsInt i) ty)
 154   = returnDs (Lit (NoRepInteger i ty))
 155
 156 dsExpr (HsLitOut (HsFrac r) ty)
 157   = returnDs (Lit (NoRepRational r ty))
 158
 159 -- others where we know what to do:
 160
 161 dsExpr (HsLitOut (HsIntPrim i) _)
 162   = if (i >= toInteger minInt && i <= toInteger maxInt) then
 163         returnDs (Lit (mkMachInt i))
 164     else
 165         error ("ERROR: Int constant " ++ show i ++ out_of_range_msg)
 166
 167 dsExpr (HsLitOut (HsFloatPrim f) _)
 168   = returnDs (Lit (MachFloat f))
 169     -- ToDo: range checking needed!
 170
 171 dsExpr (HsLitOut (HsDoublePrim d) _)
 172   = returnDs (Lit (MachDouble d))
 173     -- ToDo: range checking needed!
 174
 175 dsExpr (HsLitOut (HsChar c) _)
 176   = returnDs ( mkCon charDataCon [] [LitArg (MachChar c)] )
 177
 178 dsExpr (HsLitOut (HsCharPrim c) _)
 179   = returnDs (Lit (MachChar c))
 180
 181 dsExpr (HsLitOut (HsStringPrim s) _)
 182   = returnDs (Lit (MachStr s))
 183
 184 -- end of literals magic. --
 185
 186 dsExpr expr@(HsLam a_Match)
 187   = matchWrapper LambdaMatch [a_Match] "lambda" `thenDs` \ (binders, matching_code) ->
 188     returnDs ( mkValLam binders matching_code )
 189
 190 dsExpr expr@(HsApp fun arg)
 191   = dsExpr fun          `thenDs` \ core_fun ->
 192     dsExpr arg          `thenDs` \ core_arg ->
 193     dsExprToAtomGivenTy core_arg (coreExprType core_arg)        $ \ atom_arg ->
 194     returnDs (core_fun `App` atom_arg)
 195
 196 \end{code}
 197
 198 Operator sections.  At first it looks as if we can convert
 199 \begin{verbatim}
 200         (expr op)
 201 \end{verbatim}
 202 to
 203 \begin{verbatim}
 204         \x -> op expr x
 205 \end{verbatim}
 206
 207 But no!  expr might be a redex, and we can lose laziness badly this
 208 way.  Consider
 209 \begin{verbatim}
 210         map (expr op) xs
 211 \end{verbatim}
 212 for example.  So we convert instead to
 213 \begin{verbatim}
 214         let y = expr in \x -> op y x
 215 \end{verbatim}
 216 If \tr{expr} is actually just a variable, say, then the simplifier
 217 will sort it out.
 218
 219 \begin{code}
 220 dsExpr (OpApp e1 op _ e2)
 221   = dsExpr op                                           `thenDs` \ core_op ->
 222     -- for the type of y, we need the type of op's 2nd argument
 223     let
 224         (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op)
 225     in
 226     dsExpr e1                           `thenDs` \ x_core ->
 227     dsExpr e2                           `thenDs` \ y_core ->
 228     dsExprToAtomGivenTy x_core x_ty     $ \ x_atom ->
 229     dsExprToAtomGivenTy y_core y_ty     $ \ y_atom ->
 230     returnDs (core_op `App` x_atom `App` y_atom)
 231
 232 dsExpr (SectionL expr op)
 233   = dsExpr op                                           `thenDs` \ core_op ->
 234     -- for the type of y, we need the type of op's 2nd argument
 235     let
 236         (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op)
 237     in
 238     dsExpr expr                         `thenDs` \ x_core ->
 239     dsExprToAtomGivenTy x_core x_ty     $ \ x_atom ->
 240
 241     newSysLocalDs y_ty                  `thenDs` \ y_id ->
 242     returnDs (mkValLam [y_id] (core_op `App` x_atom `App` VarArg y_id))
 243
 244 -- dsExpr (SectionR op expr)    -- \ x -> op x expr
 245 dsExpr (SectionR op expr)
 246   = dsExpr op                   `thenDs` \ core_op ->
 247     -- for the type of x, we need the type of op's 2nd argument
 248     let
 249         (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op)
 250     in
 251     dsExpr expr                         `thenDs` \ y_expr ->
 252     dsExprToAtomGivenTy y_expr y_ty     $ \ y_atom ->
 253
 254     newSysLocalDs x_ty                  `thenDs` \ x_id ->
 255     returnDs (mkValLam [x_id] (core_op `App` VarArg x_id `App` y_atom))
 256
 257 dsExpr (CCall label args may_gc is_asm result_ty)
 258   = mapDs dsExpr args           `thenDs` \ core_args ->
 259     dsCCall label core_args may_gc is_asm result_ty
 260         -- dsCCall does all the unboxification, etc.
 261
 262 dsExpr (HsSCC cc expr)
 263   = dsExpr expr                 `thenDs` \ core_expr ->
 264     getModuleAndGroupDs         `thenDs` \ (mod_name, group_name) ->
 265     returnDs ( SCC (mkUserCC cc mod_name group_name) core_expr)
 266
 267 dsExpr expr@(HsCase discrim matches src_loc)
 268   = putSrcLocDs src_loc $
 269     dsExpr discrim                              `thenDs` \ core_discrim ->
 270     matchWrapper CaseMatch matches "case"       `thenDs` \ ([discrim_var], matching_code) ->
 271     returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code )
 272
 273 dsExpr (HsLet binds expr)
 274   = dsBinds False binds     `thenDs` \ core_binds ->
 275     dsExpr expr             `thenDs` \ core_expr ->
 276     returnDs ( mkCoLetsAny core_binds core_expr )
 277
 278 dsExpr (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty src_loc)
 279   | maybeToBool maybe_list_comp
 280   =     -- Special case for list comprehensions
 281     putSrcLocDs src_loc $
 282     dsListComp stmts elt_ty
 283
 284   | otherwise
 285   = putSrcLocDs src_loc $
 286     dsDo do_or_lc stmts return_id then_id zero_id result_ty
 287   where
 288     maybe_list_comp
 289         = case (do_or_lc, splitTyConApp_maybe result_ty) of
 290             (ListComp, Just (tycon, [elt_ty]))
 291                   | tycon == listTyCon
 292                  -> Just elt_ty
 293             other -> Nothing
 294         -- We need the ListComp form to use deListComp (rather than the "do" form)
 295         -- because the "return" in a do block is a call to "PrelBase.return", and
 296         -- not a ReturnStmt.  Only the ListComp form has ReturnStmts
 297
 298     Just elt_ty = maybe_list_comp
 299
 300 dsExpr (HsIf guard_expr then_expr else_expr src_loc)
 301   = putSrcLocDs src_loc $
 302     dsExpr guard_expr   `thenDs` \ core_guard ->
 303     dsExpr then_expr    `thenDs` \ core_then ->
 304     dsExpr else_expr    `thenDs` \ core_else ->
 305     returnDs (mkCoreIfThenElse core_guard core_then core_else)
 306 \end{code}
 307
 308
 309 Type lambda and application
 310 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 311 \begin{code}
 312 dsExpr (TyLam tyvars expr)
 313   = dsExpr expr `thenDs` \ core_expr ->
 314     returnDs (mkTyLam tyvars core_expr)
 315
 316 dsExpr (TyApp expr tys)
 317   = dsExpr expr         `thenDs` \ core_expr ->
 318     returnDs (mkTyApp core_expr tys)
 319 \end{code}
 320
 321
 322 Various data construction things
 323 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 324 \begin{code}
 325 dsExpr (ExplicitListOut ty xs)
 326   = go xs
 327   where
 328     list_ty   = mkListTy ty
 329
 330         -- xs can ocasaionlly be huge, so don't try to take
 331         -- coreExprType of core_xs, as dsArgToAtom does
 332         -- (that gives a quadratic algorithm)
 333     go []     = returnDs (mk_nil_con ty)
 334     go (x:xs) = dsExpr x                                `thenDs` \ core_x ->
 335                 dsExprToAtomGivenTy core_x ty           $ \ arg_x ->
 336                 go xs                                   `thenDs` \ core_xs ->
 337                 dsExprToAtomGivenTy core_xs list_ty     $ \ arg_xs ->
 338                 returnDs (Con consDataCon [TyArg ty, arg_x, arg_xs])
 339
 340 dsExpr (ExplicitTuple expr_list)
 341   = mapDs dsExpr expr_list        `thenDs` \ core_exprs  ->
 342     mkConDs (tupleCon (length expr_list))
 343             (map (TyArg . coreExprType) core_exprs ++ map VarArg core_exprs)
 344
 345 dsExpr (HsCon con_id [ty] [arg])
 346   | isNewTyCon tycon
 347   = dsExpr arg               `thenDs` \ arg' ->
 348     returnDs (Coerce (CoerceIn con_id) result_ty arg')
 349   where
 350     result_ty = mkTyConApp tycon [ty]
 351     tycon     = dataConTyCon con_id
 352
 353 dsExpr (HsCon con_id tys args)
 354   = mapDs dsExpr args             `thenDs` \ args2  ->
 355     mkConDs con_id (map TyArg tys ++ map VarArg args2)
 356
 357 dsExpr (ArithSeqOut expr (From from))
 358   = dsExpr expr           `thenDs` \ expr2 ->
 359     dsExpr from           `thenDs` \ from2 ->
 360     mkAppDs expr2 [VarArg from2]
 361
 362 dsExpr (ArithSeqOut expr (FromTo from two))
 363   = dsExpr expr           `thenDs` \ expr2 ->
 364     dsExpr from           `thenDs` \ from2 ->
 365     dsExpr two            `thenDs` \ two2 ->
 366     mkAppDs expr2 [VarArg from2, VarArg two2]
 367
 368 dsExpr (ArithSeqOut expr (FromThen from thn))
 369   = dsExpr expr           `thenDs` \ expr2 ->
 370     dsExpr from           `thenDs` \ from2 ->
 371     dsExpr thn            `thenDs` \ thn2 ->
 372     mkAppDs expr2 [VarArg from2, VarArg thn2]
 373
 374 dsExpr (ArithSeqOut expr (FromThenTo from thn two))
 375   = dsExpr expr           `thenDs` \ expr2 ->
 376     dsExpr from           `thenDs` \ from2 ->
 377     dsExpr thn            `thenDs` \ thn2 ->
 378     dsExpr two            `thenDs` \ two2 ->
 379     mkAppDs expr2 [VarArg from2, VarArg thn2, VarArg two2]
 380 \end{code}
 381
 382 Record construction and update
 383 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 384 For record construction we do this (assuming T has three arguments)
 385
 386         T { op2 = e }
 387 ==>
 388         let err = /\a -> recConErr a
 389         T (recConErr t1 "M.lhs/230/op1")
 390           e
 391           (recConErr t1 "M.lhs/230/op3")
 392
 393 recConErr then converts its arugment string into a proper message
 394 before printing it as
 395
 396         M.lhs, line 230: missing field op1 was evaluated
 397
 398
 399 \begin{code}
 400 dsExpr (RecordCon con_id con_expr rbinds)
 401   = dsExpr con_expr     `thenDs` \ con_expr' ->
 402     let
 403         (arg_tys, _) = splitFunTys (coreExprType con_expr')
 404
 405         mk_arg (arg_ty, lbl)
 406           = case [rhs | (sel_id,rhs,_) <- rbinds,
 407                         lbl == recordSelectorFieldLabel sel_id] of
 408               (rhs:rhss) -> ASSERT( null rhss )
 409                             dsExpr rhs
 410               []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl)
 411     in
 412     mapDs mk_arg (zipEqual "dsExpr:RecordCon" arg_tys (dataConFieldLabels con_id)) `thenDs` \ con_args ->
 413     mkAppDs con_expr' (map VarArg con_args)
 414 \end{code}
 415
 416 Record update is a little harder. Suppose we have the decl:
 417
 418         data T = T1 {op1, op2, op3 :: Int}
 419                | T2 {op4, op2 :: Int}
 420                | T3
 421
 422 Then we translate as follows:
 423
 424         r { op2 = e }
 425 ===>
 426         let op2 = e in
 427         case r of
 428           T1 op1 _ op3 -> T1 op1 op2 op3
 429           T2 op4 _     -> T2 op4 op2
 430           other        -> recUpdError "M.lhs/230"
 431
 432 It's important that we use the constructor Ids for T1, T2 etc on the
 433 RHSs, and do not generate a Core Con directly, because the constructor
 434 might do some argument-evaluation first; and may have to throw away some
 435 dictionaries.
 436
 437 \begin{code}
 438 dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
 439   = dsExpr record_expr   `thenDs` \ record_expr' ->
 440
 441         -- Desugar the rbinds, and generate let-bindings if
 442         -- necessary so that we don't lose sharing
 443     dsRbinds rbinds             $ \ rbinds' ->
 444     let
 445         record_in_ty               = coreExprType record_expr'
 446         (tycon, in_inst_tys, cons) = splitAlgTyConApp record_in_ty
 447         (_,     out_inst_tys, _)   = splitAlgTyConApp record_out_ty
 448         cons_to_upd                = filter has_all_fields cons
 449
 450         -- initial_args are passed to every constructor
 451         initial_args            = map TyArg out_inst_tys ++ map VarArg dicts
 452
 453         mk_val_arg (field, arg_id)
 454           = case [arg | (f, arg) <- rbinds',
 455                         field == recordSelectorFieldLabel f] of
 456               (arg:args) -> ASSERT(null args)
 457                             arg
 458               []         -> VarArg arg_id
 459
 460         mk_alt con
 461           = newSysLocalsDs (dataConArgTys con in_inst_tys)      `thenDs` \ arg_ids ->
 462             let
 463                 val_args = map mk_val_arg (zipEqual "dsExpr:RecordUpd" (dataConFieldLabels con) arg_ids)
 464             in
 465             returnDs (con, arg_ids, mkGenApp (mkGenApp (Var con) initial_args) val_args)
 466
 467         mk_default
 468           | length cons_to_upd == length cons
 469           = returnDs NoDefault
 470           | otherwise
 471           = newSysLocalDs record_in_ty                          `thenDs` \ deflt_id ->
 472             mkErrorAppDs rEC_UPD_ERROR_ID record_out_ty ""      `thenDs` \ err ->
 473             returnDs (BindDefault deflt_id err)
 474     in
 475     mapDs mk_alt cons_to_upd    `thenDs` \ alts ->
 476     mk_default                  `thenDs` \ deflt ->
 477
 478     returnDs (Case record_expr' (AlgAlts alts deflt))
 479
 480   where
 481     has_all_fields :: Id -> Bool
 482     has_all_fields con_id
 483       = all ok rbinds
 484       where
 485         con_fields        = dataConFieldLabels con_id
 486         ok (sel_id, _, _) = recordSelectorFieldLabel sel_id `elem` con_fields
 487 \end{code}
 488
 489 Dictionary lambda and application
 490 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 491 @DictLam@ and @DictApp@ turn into the regular old things.
 492 (OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more
 493 complicated; reminiscent of fully-applied constructors.
 494 \begin{code}
 495 dsExpr (DictLam dictvars expr)
 496   = dsExpr expr `thenDs` \ core_expr ->
 497     returnDs (mkValLam dictvars core_expr)
 498
 499 ------------------
 500
 501 dsExpr (DictApp expr dicts)     -- becomes a curried application
 502   = mapDs lookupEnvDs dicts     `thenDs` \ core_dicts ->
 503     dsExpr expr                 `thenDs` \ core_expr ->
 504     returnDs (foldl (\f d -> f `App` (VarArg d)) core_expr core_dicts)
 505 \end{code}
 506
 507 \begin{code}
 508
 509
 510 #ifdef DEBUG
 511 -- HsSyn constructs that just shouldn't be here:
 512 dsExpr (HsDo _ _ _)         = panic "dsExpr:HsDo"
 513 dsExpr (ExplicitList _)     = panic "dsExpr:ExplicitList"
 514 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
 515 dsExpr (ArithSeqIn _)       = panic "dsExpr:ArithSeqIn"
 516 #endif
 517
 518 out_of_range_msg                           -- ditto
 519   = " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n"
 520 \end{code}
 521
 522
 523 %--------------------------------------------------------------------
 524
 525 \begin{code}
 526 dsId v
 527   = lookupEnvDs v       `thenDs` \ v' ->
 528     returnDs (Var v')
 529 \end{code}
 530
 531 \begin{code}
 532 dsRbinds :: TypecheckedRecordBinds              -- The field bindings supplied
 533          -> ([(Id, CoreArg)] -> DsM CoreExpr)   -- A continuation taking the field
 534                                                 -- bindings with atomic rhss
 535          -> DsM CoreExpr                        -- The result of the continuation,
 536                                                 -- wrapped in suitable Lets
 537
 538 dsRbinds [] continue_with
 539   = continue_with []
 540
 541 dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with
 542   = dsExpr rhs                                          `thenDs` \ rhs' ->
 543     dsExprToAtomGivenTy rhs' (coreExprType rhs')        $ \ rhs_atom ->
 544     dsRbinds rbinds                                     $ \ rbinds' ->
 545     continue_with ((sel_id, rhs_atom) : rbinds')
 546 \end{code}
 547
 548 \begin{code}
 549 -- do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args)
 550 --   = do_unfold (addToTyVarEnv ty_env tyvar ty) val_env body args
 551 --
 552 -- do_unfold ty_env val_env (Lam (ValBinder binder) body) (arg@(VarArg expr) : args)
 553 --   = dsExprToAtom arg  $ \ arg_atom ->
 554 --     do_unfold ty_env
 555 --      (addOneToIdEnv val_env binder (argToExpr arg_atom))
 556 --            body args
 557 --
 558 -- do_unfold ty_env val_env body args
 559 --   =  -- Clone the remaining part of the template
 560 --    uniqSMtoDsM (substCoreExpr val_env ty_env body)   `thenDs` \ body' ->
 561 --
 562 --      -- Apply result to remaining arguments
 563 --    mkAppDs body' args
 564 \end{code}
 565
 566 Basically does the translation given in the Haskell~1.3 report:
 567 \begin{code}
 568 dsDo    :: DoOrListComp
 569         -> [TypecheckedStmt]
 570         -> Id           -- id for: return m
 571         -> Id           -- id for: (>>=) m
 572         -> Id           -- id for: zero m
 573         -> Type         -- Element type; the whole expression has type (m t)
 574         -> DsM CoreExpr
 575
 576 dsDo do_or_lc stmts return_id then_id zero_id result_ty
 577   = dsId return_id      `thenDs` \ return_ds ->
 578     dsId then_id        `thenDs` \ then_ds ->
 579     dsId zero_id        `thenDs` \ zero_ds ->
 580     let
 581         (_, b_ty) = splitAppTy result_ty        -- result_ty must be of the form (m b)
 582
 583         go [ReturnStmt expr]
 584           = dsExpr expr                 `thenDs` \ expr2 ->
 585             mkAppDs return_ds [TyArg b_ty, VarArg expr2]
 586
 587         go (GuardStmt expr locn : stmts)
 588           = do_expr expr locn                   `thenDs` \ expr2 ->
 589             go stmts                            `thenDs` \ rest ->
 590             mkAppDs zero_ds [TyArg b_ty]        `thenDs` \ zero_expr ->
 591             returnDs (mkCoreIfThenElse expr2 rest zero_expr)
 592
 593         go (ExprStmt expr locn : stmts)
 594           = do_expr expr locn           `thenDs` \ expr2 ->
 595             let
 596                 (_, a_ty) = splitAppTy (coreExprType expr2)     -- Must be of form (m a)
 597             in
 598             if null stmts then
 599                 returnDs expr2
 600             else
 601                 go stmts                `thenDs` \ rest  ->
 602                 newSysLocalDs a_ty              `thenDs` \ ignored_result_id ->
 603                 mkAppDs then_ds [TyArg a_ty, TyArg b_ty, VarArg expr2,
 604                                    VarArg (mkValLam [ignored_result_id] rest)]
 605
 606         go (LetStmt binds : stmts )
 607           = dsBinds False binds   `thenDs` \ binds2 ->
 608             go stmts              `thenDs` \ rest   ->
 609             returnDs (mkCoLetsAny binds2 rest)
 610
 611         go (BindStmt pat expr locn : stmts)
 612           = putSrcLocDs locn $
 613             dsExpr expr            `thenDs` \ expr2 ->
 614             let
 615                 (_, a_ty)  = splitAppTy (coreExprType expr2)    -- Must be of form (m a)
 616                 zero_expr  = TyApp (HsVar zero_id) [b_ty]
 617                 main_match = PatMatch pat (SimpleMatch (
 618                              HsDoOut do_or_lc stmts return_id then_id zero_id result_ty locn))
 619                 the_matches
 620                   = if failureFreePat pat
 621                     then [main_match]
 622                     else [main_match, PatMatch (WildPat a_ty) (SimpleMatch zero_expr)]
 623             in
 624             matchWrapper DoBindMatch the_matches match_msg
 625                                 `thenDs` \ (binders, matching_code) ->
 626             mkAppDs then_ds [TyArg a_ty, TyArg b_ty,
 627                              VarArg expr2, VarArg (mkValLam binders matching_code)]
 628     in
 629     go stmts
 630
 631   where
 632     do_expr expr locn = putSrcLocDs locn (dsExpr expr)
 633
 634     match_msg = case do_or_lc of
 635                         DoStmt   -> "`do' statement"
 636                         ListComp -> "comprehension"
 637 \end{code}