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