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