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