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