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