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