compiler/deSugar/DsExpr.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Desugaring exporessions.
   7
   8 \begin{code}
   9 {-# OPTIONS -fno-warn-incomplete-patterns #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
  17
  18 #include "HsVersions.h"
  19
  20 import Match
  21 import MatchLit
  22 import DsBinds
  23 import DsGRHSs
  24 import DsListComp
  25 import DsUtils
  26 import DsArrows
  27 import DsMonad
  28 import Name
  29
  30 #ifdef GHCI
  31 import PrelNames
  32         -- Template Haskell stuff iff bootstrapped
  33 import DsMeta
  34 #endif
  35
  36 import HsSyn
  37 import TcHsSyn
  38
  39 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
  40 --     needs to see source types
  41 import TcType
  42 import Type
  43 import CoreSyn
  44 import CoreUtils
  45
  46 import DynFlags
  47 import CostCentre
  48 import Id
  49 import PrelInfo
  50 import DataCon
  51 import TysWiredIn
  52 import BasicTypes
  53 import PrelNames
  54 import SrcLoc
  55 import Util
  56 import Bag
  57 import Outputable
  58 import FastString
  59 \end{code}
  60
  61
  62 %************************************************************************
  63 %*                                                                      *
  64                 dsLocalBinds, dsValBinds
  65 %*                                                                      *
  66 %************************************************************************
  67
  68 \begin{code}
  69 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
  70 dsLocalBinds EmptyLocalBinds    body = return body
  71 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
  72 dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body
  73
  74 -------------------------
  75 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
  76 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
  77
  78 -------------------------
  79 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
  80 dsIPBinds (IPBinds ip_binds dict_binds) body
  81   = do  { prs <- dsLHsBinds dict_binds
  82         ; let inner = Let (Rec prs) body
  83                 -- The dict bindings may not be in
  84                 -- dependency order; hence Rec
  85         ; foldrM ds_ip_bind inner ip_binds }
  86   where
  87     ds_ip_bind (L _ (IPBind n e)) body
  88       = do e' <- dsLExpr e
  89            return (Let (NonRec (ipNameName n) e') body)
  90
  91 -------------------------
  92 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
  93 -- Special case for bindings which bind unlifted variables
  94 -- We need to do a case right away, rather than building
  95 -- a tuple and doing selections.
  96 -- Silently ignore INLINE and SPECIALISE pragmas...
  97 ds_val_bind (NonRecursive, hsbinds) body
  98   | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
  99     (L loc bind : null_binds) <- bagToList binds,
 100     isBangHsBind bind
 101     || isUnboxedTupleBind bind
 102     || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
 103   = let
 104       body_w_exports                  = foldr bind_export body exports
 105       bind_export (tvs, g, l, _) body = ASSERT( null tvs )
 106                                         bindNonRec g (Var l) body
 107     in
 108     ASSERT (null null_binds)
 109         -- Non-recursive, non-overloaded bindings only come in ones
 110         -- ToDo: in some bizarre case it's conceivable that there
 111         --       could be dict binds in the 'binds'.  (See the notes
 112         --       below.  Then pattern-match would fail.  Urk.)
 113     putSrcSpanDs loc    $
 114     case bind of
 115       FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn,
 116                 fun_tick = tick, fun_infix = inf }
 117         -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
 118               MASSERT( null args ) -- Functions aren't lifted
 119               MASSERT( isIdHsWrapper co_fn )
 120               rhs' <- mkOptTickBox tick rhs
 121               return (bindNonRec fun rhs' body_w_exports)
 122
 123       PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
 124         ->      -- let C x# y# = rhs in body
 125                 -- ==> case rhs of C x# y# -> body
 126            putSrcSpanDs loc                     $
 127            do { rhs <- dsGuarded grhss ty
 128               ; let upat = unLoc pat
 129                     eqn = EqnInfo { eqn_pats = [upat],
 130                                     eqn_rhs = cantFailMatchResult body_w_exports }
 131               ; var    <- selectMatchVar upat
 132               ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
 133               ; return (scrungleMatch var rhs result) }
 134
 135       _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
 136
 137
 138 -- Ordinary case for bindings; none should be unlifted
 139 ds_val_bind (_is_rec, binds) body
 140   = do  { prs <- dsLHsBinds binds
 141         ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
 142           case prs of
 143             [] -> return body
 144             _  -> return (Let (Rec prs) body) }
 145         -- Use a Rec regardless of is_rec.
 146         -- Why? Because it allows the binds to be all
 147         -- mixed up, which is what happens in one rare case
 148         -- Namely, for an AbsBind with no tyvars and no dicts,
 149         --         but which does have dictionary bindings.
 150         -- See notes with TcSimplify.inferLoop [NO TYVARS]
 151         -- It turned out that wrapping a Rec here was the easiest solution
 152         --
 153         -- NB The previous case dealt with unlifted bindings, so we
 154         --    only have to deal with lifted ones now; so Rec is ok
 155
 156 isUnboxedTupleBind :: HsBind Id -> Bool
 157 isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
 158 isUnboxedTupleBind _                             = False
 159
 160 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 161 -- Returns something like (let var = scrut in body)
 162 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
 163 -- Special case to handle unboxed tuple patterns; they can't appear nested
 164 -- The idea is that
 165 --      case e of (# p1, p2 #) -> rhs
 166 -- should desugar to
 167 --      case e of (# x1, x2 #) -> ... match p1, p2 ...
 168 -- NOT
 169 --      let x = e in case x of ....
 170 --
 171 -- But there may be a big
 172 --      let fail = ... in case e of ...
 173 -- wrapping the whole case, which complicates matters slightly
 174 -- It all seems a bit fragile.  Test is dsrun013.
 175
 176 scrungleMatch var scrut body
 177   | isUnboxedTupleType (idType var) = scrungle body
 178   | otherwise                       = bindNonRec var scrut body
 179   where
 180     scrungle (Case (Var x) bndr ty alts)
 181                     | x == var = Case scrut bndr ty alts
 182     scrungle (Let binds body)  = Let binds (scrungle body)
 183     scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
 184
 185 \end{code}
 186
 187 %************************************************************************
 188 %*                                                                      *
 189 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
 190 %*                                                                      *
 191 %************************************************************************
 192
 193 \begin{code}
 194 dsLExpr :: LHsExpr Id -> DsM CoreExpr
 195
 196 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
 197
 198 dsExpr :: HsExpr Id -> DsM CoreExpr
 199 dsExpr (HsPar e)              = dsLExpr e
 200 dsExpr (ExprWithTySigOut e _) = dsLExpr e
 201 dsExpr (HsVar var)            = return (Var var)
 202 dsExpr (HsIPVar ip)           = return (Var (ipNameName ip))
 203 dsExpr (HsLit lit)            = dsLit lit
 204 dsExpr (HsOverLit lit)        = dsOverLit lit
 205 dsExpr (HsWrap co_fn e)       = dsCoercion co_fn (dsExpr e)
 206
 207 dsExpr (NegApp expr neg_expr)
 208   = App <$> dsExpr neg_expr <*> dsLExpr expr
 209
 210 dsExpr (HsLam a_Match)
 211   = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
 212
 213 dsExpr (HsApp fun arg)
 214   = mkDsApp <$> dsLExpr fun <*>  dsLExpr arg
 215 \end{code}
 216
 217 Operator sections.  At first it looks as if we can convert
 218 \begin{verbatim}
 219         (expr op)
 220 \end{verbatim}
 221 to
 222 \begin{verbatim}
 223         \x -> op expr x
 224 \end{verbatim}
 225
 226 But no!  expr might be a redex, and we can lose laziness badly this
 227 way.  Consider
 228 \begin{verbatim}
 229         map (expr op) xs
 230 \end{verbatim}
 231 for example.  So we convert instead to
 232 \begin{verbatim}
 233         let y = expr in \x -> op y x
 234 \end{verbatim}
 235 If \tr{expr} is actually just a variable, say, then the simplifier
 236 will sort it out.
 237
 238 \begin{code}
 239 dsExpr (OpApp e1 op _ e2)
 240   = -- for the type of y, we need the type of op's 2nd argument
 241     mkDsApps <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
 242
 243 dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
 244   = mkDsApp <$> dsLExpr op <*> dsLExpr expr
 245
 246 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
 247 dsExpr (SectionR op expr) = do
 248     core_op <- dsLExpr op
 249     -- for the type of x, we need the type of op's 2nd argument
 250     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
 251         -- See comment with SectionL
 252     y_core <- dsLExpr expr
 253     x_id <- newSysLocalDs x_ty
 254     y_id <- newSysLocalDs y_ty
 255     return (bindNonRec y_id y_core $
 256             Lam x_id (mkDsApps core_op [Var x_id, Var y_id]))
 257
 258 dsExpr (HsSCC cc expr) = do
 259     mod_name <- getModuleDs
 260     Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
 261
 262
 263 -- hdaume: core annotation
 264
 265 dsExpr (HsCoreAnn fs expr)
 266   = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
 267
 268 dsExpr (HsCase discrim matches) = do
 269     core_discrim <- dsLExpr discrim
 270     ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
 271     return (scrungleMatch discrim_var core_discrim matching_code)
 272
 273 -- Pepe: The binds are in scope in the body but NOT in the binding group
 274 --       This is to avoid silliness in breakpoints
 275 dsExpr (HsLet binds body) = do
 276     body' <- dsLExpr body
 277     dsLocalBinds binds body'
 278
 279 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
 280 -- because the interpretation of `stmts' depends on what sort of thing it is.
 281 --
 282 dsExpr (HsDo ListComp stmts body result_ty)
 283   =     -- Special case for list comprehensions
 284     dsListComp stmts body elt_ty
 285   where
 286     [elt_ty] = tcTyConAppArgs result_ty
 287
 288 dsExpr (HsDo DoExpr stmts body result_ty)
 289   = dsDo stmts body result_ty
 290
 291 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
 292   = dsMDo tbl stmts body result_ty
 293
 294 dsExpr (HsDo PArrComp stmts body result_ty)
 295   =     -- Special case for array comprehensions
 296     dsPArrComp (map unLoc stmts) body elt_ty
 297   where
 298     [elt_ty] = tcTyConAppArgs result_ty
 299
 300 dsExpr (HsIf guard_expr then_expr else_expr)
 301   = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
 302 \end{code}
 303
 304
 305 \noindent
 306 \underline{\bf Various data construction things}
 307 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 308 \begin{code}
 309 dsExpr (ExplicitList elt_ty xs)
 310   = dsExplicitList elt_ty xs
 311
 312 -- we create a list from the array elements and convert them into a list using
 313 -- `PrelPArr.toP'
 314 --
 315 --  * the main disadvantage to this scheme is that `toP' traverses the list
 316 --   twice: once to determine the length and a second time to put to elements
 317 --   into the array; this inefficiency could be avoided by exposing some of
 318 --   the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so
 319 --   that we can exploit the fact that we already know the length of the array
 320 --   here at compile time
 321 --
 322 dsExpr (ExplicitPArr ty xs) = do
 323     toP <- dsLookupGlobalId toPName
 324     coreList <- dsExpr (ExplicitList ty xs)
 325     return (mkApps (Var toP) [Type ty, coreList])
 326
 327 dsExpr (ExplicitTuple expr_list boxity) = do
 328     core_exprs <- mapM dsLExpr expr_list
 329     return (mkConApp (tupleCon boxity (length expr_list))
 330                   (map (Type .  exprType) core_exprs ++ core_exprs))
 331
 332 dsExpr (ArithSeq expr (From from))
 333   = App <$> dsExpr expr <*> dsLExpr from
 334
 335 dsExpr (ArithSeq expr (FromTo from to))
 336   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
 337
 338 dsExpr (ArithSeq expr (FromThen from thn))
 339   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
 340
 341 dsExpr (ArithSeq expr (FromThenTo from thn to))
 342   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
 343
 344 dsExpr (PArrSeq expr (FromTo from to))
 345   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
 346
 347 dsExpr (PArrSeq expr (FromThenTo from thn to))
 348   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
 349
 350 dsExpr (PArrSeq _ _)
 351   = panic "DsExpr.dsExpr: Infinite parallel array!"
 352     -- the parser shouldn't have generated it and the renamer and typechecker
 353     -- shouldn't have let it through
 354 \end{code}
 355
 356 \noindent
 357 \underline{\bf Record construction and update}
 358 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 359 For record construction we do this (assuming T has three arguments)
 360 \begin{verbatim}
 361         T { op2 = e }
 362 ==>
 363         let err = /\a -> recConErr a
 364         T (recConErr t1 "M.lhs/230/op1")
 365           e
 366           (recConErr t1 "M.lhs/230/op3")
 367 \end{verbatim}
 368 @recConErr@ then converts its arugment string into a proper message
 369 before printing it as
 370 \begin{verbatim}
 371         M.lhs, line 230: missing field op1 was evaluated
 372 \end{verbatim}
 373
 374 We also handle @C{}@ as valid construction syntax for an unlabelled
 375 constructor @C@, setting all of @C@'s fields to bottom.
 376
 377 \begin{code}
 378 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
 379     con_expr' <- dsExpr con_expr
 380     let
 381         (arg_tys, _) = tcSplitFunTys (exprType con_expr')
 382         -- A newtype in the corner should be opaque;
 383         -- hence TcType.tcSplitFunTys
 384
 385         mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
 386           = case findField (rec_flds rbinds) lbl of
 387               (rhs:rhss) -> ASSERT( null rhss )
 388                             dsLExpr rhs
 389               []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
 390         unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
 391
 392         labels = dataConFieldLabels (idDataCon data_con_id)
 393         -- The data_con_id is guaranteed to be the wrapper id of the constructor
 394
 395     con_args <- if null labels
 396                 then mapM unlabelled_bottom arg_tys
 397                 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
 398
 399     return (mkApps con_expr' con_args)
 400 \end{code}
 401
 402 Record update is a little harder. Suppose we have the decl:
 403 \begin{verbatim}
 404         data T = T1 {op1, op2, op3 :: Int}
 405                | T2 {op4, op2 :: Int}
 406                | T3
 407 \end{verbatim}
 408 Then we translate as follows:
 409 \begin{verbatim}
 410         r { op2 = e }
 411 ===>
 412         let op2 = e in
 413         case r of
 414           T1 op1 _ op3 -> T1 op1 op2 op3
 415           T2 op4 _     -> T2 op4 op2
 416           other        -> recUpdError "M.lhs/230"
 417 \end{verbatim}
 418 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
 419 RHSs, and do not generate a Core constructor application directly, because the constructor
 420 might do some argument-evaluation first; and may have to throw away some
 421 dictionaries.
 422
 423 \begin{code}
 424 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
 425                        cons_to_upd in_inst_tys out_inst_tys)
 426   | null fields
 427   = dsLExpr record_expr
 428   | otherwise
 429   =     -- Record stuff doesn't work for existentials
 430         -- The type checker checks for this, but we need
 431         -- worry only about the constructors that are to be updated
 432     ASSERT2( notNull cons_to_upd && all isVanillaDataCon cons_to_upd, ppr expr )
 433
 434     do  { record_expr' <- dsLExpr record_expr
 435         ; let   -- Awkwardly, for families, the match goes
 436                 -- from instance type to family type
 437                 tycon     = dataConTyCon (head cons_to_upd)
 438                 in_ty     = mkTyConApp tycon in_inst_tys
 439                 in_out_ty = mkFunTy in_ty
 440                                     (mkFamilyTyConApp tycon out_inst_tys)
 441
 442                 mk_val_arg field old_arg_id
 443                   = case findField fields field  of
 444                       (rhs:rest) -> ASSERT(null rest) rhs
 445                       []         -> nlHsVar old_arg_id
 446
 447                 mk_alt con
 448                   = ASSERT( isVanillaDataCon con )
 449                     do  { arg_ids <- newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys)
 450                         -- This call to dataConInstOrigArgTys won't work for existentials
 451                         -- but existentials don't have record types anyway
 452                         ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
 453                                                 (dataConFieldLabels con) arg_ids
 454                               rhs = foldl (\a b -> nlHsApp a b)
 455                                           (nlHsTyApp (dataConWrapId con) out_inst_tys)
 456                                           val_args
 457                               pat = mkPrefixConPat con (map nlVarPat arg_ids) in_ty
 458
 459                         ; return (mkSimpleMatch [pat] rhs) }
 460
 461         -- It's important to generate the match with matchWrapper,
 462         -- and the right hand sides with applications of the wrapper Id
 463         -- so that everything works when we are doing fancy unboxing on the
 464         -- constructor aguments.
 465         ; alts <- mapM mk_alt cons_to_upd
 466         ; ([discrim_var], matching_code) <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
 467
 468         ; return (bindNonRec discrim_var record_expr' matching_code) }
 469 \end{code}
 470
 471 Here is where we desugar the Template Haskell brackets and escapes
 472
 473 \begin{code}
 474 -- Template Haskell stuff
 475
 476 #ifdef GHCI     /* Only if bootstrapping */
 477 dsExpr (HsBracketOut x ps) = dsBracket x ps
 478 dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
 479 #endif
 480
 481 -- Arrow notation extension
 482 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
 483 \end{code}
 484
 485 Hpc Support
 486
 487 \begin{code}
 488 dsExpr (HsTick ix vars e) = do
 489   e' <- dsLExpr e
 490   mkTickBox ix vars e'
 491
 492 -- There is a problem here. The then and else branches
 493 -- have no free variables, so they are open to lifting.
 494 -- We need someway of stopping this.
 495 -- This will make no difference to binary coverage
 496 -- (did you go here: YES or NO), but will effect accurate
 497 -- tick counting.
 498
 499 dsExpr (HsBinTick ixT ixF e) = do
 500   e2 <- dsLExpr e
 501   do { ASSERT(exprType e2 `coreEqType` boolTy)
 502        mkBinaryTickBox ixT ixF e2
 503      }
 504 \end{code}
 505
 506 \begin{code}
 507
 508 -- HsSyn constructs that just shouldn't be here:
 509 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
 510
 511
 512 findField :: [HsRecField Id arg] -> Name -> [arg]
 513 findField rbinds lbl
 514   = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
 515          , lbl == idName (unLoc id) ]
 516 \end{code}
 517
 518 %--------------------------------------------------------------------
 519
 520 Note [Desugaring explicit lists]
 521 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 522 Explicit lists are desugared in a cleverer way to prevent some
 523 fruitless allocations.  Essentially, whenever we see a list literal
 524 [x_1, ..., x_n] we:
 525
 526 1. Find the tail of the list that can be allocated statically (say
 527    [x_k, ..., x_n]) by later stages and ensure we desugar that
 528    normally: this makes sure that we don't cause a code size increase
 529    by having the cons in that expression fused (see later) and hence
 530    being unable to statically allocate any more
 531
 532 2. For the prefix of the list which cannot be allocated statically,
 533    say [x_1, ..., x_(k-1)], we turn it into an expression involving
 534    build so that if we find any foldrs over it it will fuse away
 535    entirely!
 536
 537    So in this example we will desugar to:
 538    build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
 539
 540    If fusion fails to occur then build will get inlined and (since we
 541    defined a RULE for foldr (:) []) we will get back exactly the
 542    normal desugaring for an explicit list.
 543
 544 This optimisation can be worth a lot: up to 25% of the total
 545 allocation in some nofib programs. Specifically
 546
 547         Program           Size    Allocs   Runtime  CompTime
 548         rewrite          +0.0%    -26.3%      0.02     -1.8%
 549            ansi          -0.3%    -13.8%      0.00     +0.0%
 550            lift          +0.0%     -8.7%      0.00     -2.3%
 551
 552 Of course, if rules aren't turned on then there is pretty much no
 553 point doing this fancy stuff, and it may even be harmful.
 554 \begin{code}
 555
 556 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
 557 -- See Note [Desugaring explicit lists]
 558 dsExplicitList elt_ty xs = do
 559     dflags <- getDOptsDs
 560     xs' <- mapM dsLExpr xs
 561     if not (dopt Opt_RewriteRules dflags)
 562         then return $ mkListExpr elt_ty xs'
 563         else mkBuildExpr elt_ty (mkSplitExplicitList (thisPackage dflags) xs')
 564   where
 565     mkSplitExplicitList this_package xs' (c, _) (n, n_ty) = do
 566         let (dynamic_prefix, static_suffix) = spanTail (rhsIsStatic this_package) xs'
 567             static_suffix' = mkListExpr elt_ty static_suffix
 568
 569         folded_static_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) static_suffix'
 570         let build_body = foldr (App . App (Var c)) folded_static_suffix dynamic_prefix
 571         return build_body
 572
 573 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
 574 spanTail f xs = (reverse rejected, reverse satisfying)
 575     where (satisfying, rejected) = span f $ reverse xs
 576 \end{code}
 577
 578 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
 579 handled in DsListComp).  Basically does the translation given in the
 580 Haskell 98 report:
 581
 582 \begin{code}
 583 dsDo    :: [LStmt Id]
 584         -> LHsExpr Id
 585         -> Type                 -- Type of the whole expression
 586         -> DsM CoreExpr
 587
 588 dsDo stmts body _result_ty
 589   = go (map unLoc stmts)
 590   where
 591     go [] = dsLExpr body
 592
 593     go (ExprStmt rhs then_expr _ : stmts)
 594       = do { rhs2 <- dsLExpr rhs
 595            ; then_expr2 <- dsExpr then_expr
 596            ; rest <- go stmts
 597            ; return (mkApps then_expr2 [rhs2, rest]) }
 598
 599     go (LetStmt binds : stmts)
 600       = do { rest <- go stmts
 601            ; dsLocalBinds binds rest }
 602
 603     go (BindStmt pat rhs bind_op fail_op : stmts)
 604       =
 605        do  { body     <- go stmts
 606            ; rhs'     <- dsLExpr rhs
 607            ; bind_op' <- dsExpr bind_op
 608            ; var   <- selectSimpleMatchVarL pat
 609            ; let bind_ty = exprType bind_op'    -- rhs -> (pat -> res1) -> res2
 610                  res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
 611            ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
 612                                      res1_ty (cantFailMatchResult body)
 613            ; match_code <- handle_failure pat match fail_op
 614            ; return (mkApps bind_op' [rhs', Lam var match_code]) }
 615
 616     -- In a do expression, pattern-match failure just calls
 617     -- the monadic 'fail' rather than throwing an exception
 618     handle_failure pat match fail_op
 619       | matchCanFail match
 620       = do { fail_op' <- dsExpr fail_op
 621            ; fail_msg <- mkStringExpr (mk_fail_msg pat)
 622            ; extractMatchResult match (App fail_op' fail_msg) }
 623       | otherwise
 624       = extractMatchResult match (error "It can't fail")
 625
 626 mk_fail_msg :: Located e -> String
 627 mk_fail_msg pat = "Pattern match failure in do expression at " ++
 628                   showSDoc (ppr (getLoc pat))
 629 \end{code}
 630
 631 Translation for RecStmt's:
 632 -----------------------------
 633 We turn (RecStmt [v1,..vn] stmts) into:
 634
 635   (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
 636                                       return (v1,..vn))
 637
 638 \begin{code}
 639 dsMDo   :: PostTcTable
 640         -> [LStmt Id]
 641         -> LHsExpr Id
 642         -> Type                 -- Type of the whole expression
 643         -> DsM CoreExpr
 644
 645 dsMDo tbl stmts body result_ty
 646   = go (map unLoc stmts)
 647   where
 648     (m_ty, b_ty) = tcSplitAppTy result_ty       -- result_ty must be of the form (m b)
 649     mfix_id   = lookupEvidence tbl mfixName
 650     return_id = lookupEvidence tbl returnMName
 651     bind_id   = lookupEvidence tbl bindMName
 652     then_id   = lookupEvidence tbl thenMName
 653     fail_id   = lookupEvidence tbl failMName
 654     ctxt      = MDoExpr tbl
 655
 656     go [] = dsLExpr body
 657
 658     go (LetStmt binds : stmts)
 659       = do { rest <- go stmts
 660            ; dsLocalBinds binds rest }
 661
 662     go (ExprStmt rhs _ rhs_ty : stmts)
 663       = do { rhs2 <- dsLExpr rhs
 664            ; rest <- go stmts
 665            ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
 666
 667     go (BindStmt pat rhs _ _ : stmts)
 668       = do { body  <- go stmts
 669            ; var   <- selectSimpleMatchVarL pat
 670            ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
 671                                   result_ty (cantFailMatchResult body)
 672            ; fail_msg   <- mkStringExpr (mk_fail_msg pat)
 673            ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
 674            ; match_code <- extractMatchResult match fail_expr
 675
 676            ; rhs'       <- dsLExpr rhs
 677            ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
 678                                              rhs', Lam var match_code]) }
 679
 680     go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
 681       = ASSERT( length rec_ids > 0 )
 682         ASSERT( length rec_ids == length rec_rets )
 683         go (new_bind_stmt : let_stmt : stmts)
 684       where
 685         new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
 686         let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
 687
 688
 689                 -- Remove the later_ids that appear (without fancy coercions)
 690                 -- in rec_rets, because there's no need to knot-tie them separately
 691                 -- See Note [RecStmt] in HsExpr
 692         later_ids'   = filter (`notElem` mono_rec_ids) later_ids
 693         mono_rec_ids = [ id | HsVar id <- rec_rets ]
 694
 695         mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
 696         mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
 697                                              (mkFunTy tup_ty body_ty))
 698
 699         -- The rec_tup_pat must bind the rec_ids only; remember that the
 700         --      trimmed_laters may share the same Names
 701         -- Meanwhile, the later_pats must bind the later_vars
 702         rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
 703         later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
 704         rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
 705
 706         mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
 707         body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
 708         body_ty = mkAppTy m_ty tup_ty
 709         tup_ty  = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
 710                   -- mkCoreTupTy deals with singleton case
 711
 712         return_app  = nlHsApp (nlHsTyApp return_id [tup_ty])
 713                               (mk_ret_tup rets)
 714
 715         mk_wild_pat :: Id -> LPat Id
 716         mk_wild_pat v = noLoc $ WildPat $ idType v
 717
 718         mk_later_pat :: Id -> LPat Id
 719         mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
 720                        | otherwise           = nlVarPat v
 721
 722         mk_tup_pat :: [LPat Id] -> LPat Id
 723         mk_tup_pat [p] = p
 724         mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
 725
 726         mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
 727         mk_ret_tup [r] = r
 728         mk_ret_tup rs  = noLoc $ ExplicitTuple rs Boxed
 729 \end{code}