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