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