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