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_GHC -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/WorkingConventions#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 = foldrDs 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         ; foldrDs ds_ip_bind inner ip_binds }
  85   where
  86     ds_ip_bind (L _ (IPBind n e)) body
  87       = dsLExpr e       `thenDs` \ e' ->
  88         returnDs (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         -> matchWrapper (FunRhs (idName fun ) inf) matches      `thenDs` \ (args, rhs) ->
 117            ASSERT( null args )  -- Functions aren't lifted
 118            ASSERT( isIdHsWrapper co_fn )
 119            mkOptTickBox tick rhs                                `thenDs` \ rhs' ->
 120            returnDs (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)            = returnDs (Var var)
 201 dsExpr (HsIPVar ip)           = returnDs (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   = do  { core_expr <- dsLExpr expr
 208         ; core_neg  <- dsExpr neg_expr
 209         ; return (core_neg `App` core_expr) }
 210
 211 dsExpr expr@(HsLam a_Match)
 212   = matchWrapper LambdaExpr a_Match     `thenDs` \ (binders, matching_code) ->
 213     returnDs (mkLams binders matching_code)
 214
 215 dsExpr expr@(HsApp fun arg)
 216   = dsLExpr fun         `thenDs` \ core_fun ->
 217     dsLExpr arg         `thenDs` \ core_arg ->
 218     returnDs (core_fun `mkDsApp` core_arg)
 219 \end{code}
 220
 221 Operator sections.  At first it looks as if we can convert
 222 \begin{verbatim}
 223         (expr op)
 224 \end{verbatim}
 225 to
 226 \begin{verbatim}
 227         \x -> op expr x
 228 \end{verbatim}
 229
 230 But no!  expr might be a redex, and we can lose laziness badly this
 231 way.  Consider
 232 \begin{verbatim}
 233         map (expr op) xs
 234 \end{verbatim}
 235 for example.  So we convert instead to
 236 \begin{verbatim}
 237         let y = expr in \x -> op y x
 238 \end{verbatim}
 239 If \tr{expr} is actually just a variable, say, then the simplifier
 240 will sort it out.
 241
 242 \begin{code}
 243 dsExpr (OpApp e1 op _ e2)
 244   = dsLExpr op                                          `thenDs` \ core_op ->
 245     -- for the type of y, we need the type of op's 2nd argument
 246     dsLExpr e1                          `thenDs` \ x_core ->
 247     dsLExpr e2                          `thenDs` \ y_core ->
 248     returnDs (mkDsApps core_op [x_core, y_core])
 249
 250 dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
 251   = dsLExpr op                          `thenDs` \ core_op ->
 252     dsLExpr expr                        `thenDs` \ x_core ->
 253     returnDs (mkDsApp core_op x_core)
 254
 255 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
 256 dsExpr (SectionR op expr)
 257   = dsLExpr op                  `thenDs` \ core_op ->
 258     -- for the type of x, we need the type of op's 2nd argument
 259     let
 260         (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
 261         -- See comment with SectionL
 262     in
 263     dsLExpr expr                                `thenDs` \ y_core ->
 264     newSysLocalDs x_ty                  `thenDs` \ x_id ->
 265     newSysLocalDs y_ty                  `thenDs` \ y_id ->
 266
 267     returnDs (bindNonRec y_id y_core $
 268               Lam x_id (mkDsApps core_op [Var x_id, Var y_id]))
 269
 270 dsExpr (HsSCC cc expr)
 271   = dsLExpr expr                        `thenDs` \ core_expr ->
 272     getModuleDs                 `thenDs` \ mod_name ->
 273     returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr)
 274
 275
 276 -- hdaume: core annotation
 277
 278 dsExpr (HsCoreAnn fs expr)
 279   = dsLExpr expr        `thenDs` \ core_expr ->
 280     returnDs (Note (CoreNote $ unpackFS fs) core_expr)
 281
 282 dsExpr (HsCase discrim matches)
 283   = dsLExpr discrim                     `thenDs` \ core_discrim ->
 284     matchWrapper CaseAlt matches        `thenDs` \ ([discrim_var], matching_code) ->
 285     returnDs (scrungleMatch discrim_var core_discrim matching_code)
 286
 287 -- Pepe: The binds are in scope in the body but NOT in the binding group
 288 --       This is to avoid silliness in breakpoints
 289 dsExpr (HsLet binds body)
 290   = dsLExpr body `thenDs` \ body' ->
 291     dsLocalBinds binds body'
 292
 293 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
 294 -- because the interpretation of `stmts' depends on what sort of thing it is.
 295 --
 296 dsExpr (HsDo ListComp stmts body result_ty)
 297   =     -- Special case for list comprehensions
 298     dsListComp stmts body elt_ty
 299   where
 300     [elt_ty] = tcTyConAppArgs result_ty
 301
 302 dsExpr (HsDo DoExpr stmts body result_ty)
 303   = dsDo stmts body result_ty
 304
 305 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
 306   = dsMDo tbl stmts body result_ty
 307
 308 dsExpr (HsDo PArrComp stmts body result_ty)
 309   =     -- Special case for array comprehensions
 310     dsPArrComp (map unLoc stmts) body elt_ty
 311   where
 312     [elt_ty] = tcTyConAppArgs result_ty
 313
 314 dsExpr (HsIf guard_expr then_expr else_expr)
 315   = dsLExpr guard_expr  `thenDs` \ core_guard ->
 316     dsLExpr then_expr   `thenDs` \ core_then ->
 317     dsLExpr else_expr   `thenDs` \ core_else ->
 318     returnDs (mkIfThenElse core_guard core_then core_else)
 319 \end{code}
 320
 321
 322 \noindent
 323 \underline{\bf Various data construction things}
 324 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 325 \begin{code}
 326 dsExpr (ExplicitList ty xs)
 327   = go xs
 328   where
 329     go []     = returnDs (mkNilExpr ty)
 330     go (x:xs) = dsLExpr x                               `thenDs` \ core_x ->
 331                 go xs                                   `thenDs` \ core_xs ->
 332                 returnDs (mkConsExpr ty core_x core_xs)
 333
 334 -- we create a list from the array elements and convert them into a list using
 335 -- `PrelPArr.toP'
 336 --
 337 --  * the main disadvantage to this scheme is that `toP' traverses the list
 338 --   twice: once to determine the length and a second time to put to elements
 339 --   into the array; this inefficiency could be avoided by exposing some of
 340 --   the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so
 341 --   that we can exploit the fact that we already know the length of the array
 342 --   here at compile time
 343 --
 344 dsExpr (ExplicitPArr ty xs)
 345   = dsLookupGlobalId toPName                            `thenDs` \toP      ->
 346     dsExpr (ExplicitList ty xs)                         `thenDs` \coreList ->
 347     returnDs (mkApps (Var toP) [Type ty, coreList])
 348
 349 dsExpr (ExplicitTuple expr_list boxity)
 350   = mappM dsLExpr expr_list       `thenDs` \ core_exprs  ->
 351     returnDs (mkConApp (tupleCon boxity (length expr_list))
 352                        (map (Type .  exprType) core_exprs ++ core_exprs))
 353
 354 dsExpr (ArithSeq expr (From from))
 355   = dsExpr expr           `thenDs` \ expr2 ->
 356     dsLExpr from          `thenDs` \ from2 ->
 357     returnDs (App expr2 from2)
 358
 359 dsExpr (ArithSeq expr (FromTo from two))
 360   = dsExpr expr           `thenDs` \ expr2 ->
 361     dsLExpr from          `thenDs` \ from2 ->
 362     dsLExpr two           `thenDs` \ two2 ->
 363     returnDs (mkApps expr2 [from2, two2])
 364
 365 dsExpr (ArithSeq expr (FromThen from thn))
 366   = dsExpr expr           `thenDs` \ expr2 ->
 367     dsLExpr from          `thenDs` \ from2 ->
 368     dsLExpr thn           `thenDs` \ thn2 ->
 369     returnDs (mkApps expr2 [from2, thn2])
 370
 371 dsExpr (ArithSeq expr (FromThenTo from thn two))
 372   = dsExpr expr           `thenDs` \ expr2 ->
 373     dsLExpr from          `thenDs` \ from2 ->
 374     dsLExpr thn           `thenDs` \ thn2 ->
 375     dsLExpr two           `thenDs` \ two2 ->
 376     returnDs (mkApps expr2 [from2, thn2, two2])
 377
 378 dsExpr (PArrSeq expr (FromTo from two))
 379   = dsExpr expr           `thenDs` \ expr2 ->
 380     dsLExpr from          `thenDs` \ from2 ->
 381     dsLExpr two           `thenDs` \ two2 ->
 382     returnDs (mkApps expr2 [from2, two2])
 383
 384 dsExpr (PArrSeq expr (FromThenTo from thn two))
 385   = dsExpr expr           `thenDs` \ expr2 ->
 386     dsLExpr from          `thenDs` \ from2 ->
 387     dsLExpr thn           `thenDs` \ thn2 ->
 388     dsLExpr two           `thenDs` \ two2 ->
 389     returnDs (mkApps expr2 [from2, thn2, two2])
 390
 391 dsExpr (PArrSeq expr _)
 392   = panic "DsExpr.dsExpr: Infinite parallel array!"
 393     -- the parser shouldn't have generated it and the renamer and typechecker
 394     -- shouldn't have let it through
 395 \end{code}
 396
 397 \noindent
 398 \underline{\bf Record construction and update}
 399 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 400 For record construction we do this (assuming T has three arguments)
 401 \begin{verbatim}
 402         T { op2 = e }
 403 ==>
 404         let err = /\a -> recConErr a
 405         T (recConErr t1 "M.lhs/230/op1")
 406           e
 407           (recConErr t1 "M.lhs/230/op3")
 408 \end{verbatim}
 409 @recConErr@ then converts its arugment string into a proper message
 410 before printing it as
 411 \begin{verbatim}
 412         M.lhs, line 230: missing field op1 was evaluated
 413 \end{verbatim}
 414
 415 We also handle @C{}@ as valid construction syntax for an unlabelled
 416 constructor @C@, setting all of @C@'s fields to bottom.
 417
 418 \begin{code}
 419 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds)
 420   = dsExpr con_expr     `thenDs` \ con_expr' ->
 421     let
 422         (arg_tys, _) = tcSplitFunTys (exprType con_expr')
 423         -- A newtype in the corner should be opaque;
 424         -- hence TcType.tcSplitFunTys
 425
 426         mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
 427           = case findField (rec_flds rbinds) lbl of
 428               (rhs:rhss) -> ASSERT( null rhss )
 429                             dsLExpr rhs
 430               []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
 431         unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
 432
 433         labels = dataConFieldLabels (idDataCon data_con_id)
 434         -- The data_con_id is guaranteed to be the wrapper id of the constructor
 435     in
 436
 437     (if null labels
 438         then mappM unlabelled_bottom arg_tys
 439         else mappM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels))
 440         `thenDs` \ con_args ->
 441
 442     returnDs (mkApps con_expr' con_args)
 443 \end{code}
 444
 445 Record update is a little harder. Suppose we have the decl:
 446 \begin{verbatim}
 447         data T = T1 {op1, op2, op3 :: Int}
 448                | T2 {op4, op2 :: Int}
 449                | T3
 450 \end{verbatim}
 451 Then we translate as follows:
 452 \begin{verbatim}
 453         r { op2 = e }
 454 ===>
 455         let op2 = e in
 456         case r of
 457           T1 op1 _ op3 -> T1 op1 op2 op3
 458           T2 op4 _     -> T2 op4 op2
 459           other        -> recUpdError "M.lhs/230"
 460 \end{verbatim}
 461 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
 462 RHSs, and do not generate a Core constructor application directly, because the constructor
 463 might do some argument-evaluation first; and may have to throw away some
 464 dictionaries.
 465
 466 \begin{code}
 467 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
 468                        cons_to_upd in_inst_tys out_inst_tys)
 469   | null fields
 470   = dsLExpr record_expr
 471   | otherwise
 472   =     -- Record stuff doesn't work for existentials
 473         -- The type checker checks for this, but we need
 474         -- worry only about the constructors that are to be updated
 475     ASSERT2( notNull cons_to_upd && all isVanillaDataCon cons_to_upd, ppr expr )
 476
 477     do  { record_expr' <- dsLExpr record_expr
 478         ; let   -- Awkwardly, for families, the match goes
 479                 -- from instance type to family type
 480                 tycon     = dataConTyCon (head cons_to_upd)
 481                 in_ty     = mkTyConApp tycon in_inst_tys
 482                 in_out_ty = mkFunTy in_ty
 483                                     (mkFamilyTyConApp tycon out_inst_tys)
 484
 485                 mk_val_arg field old_arg_id
 486                   = case findField fields field  of
 487                       (rhs:rest) -> ASSERT(null rest) rhs
 488                       []         -> nlHsVar old_arg_id
 489
 490                 mk_alt con
 491                   = ASSERT( isVanillaDataCon con )
 492                     do  { arg_ids <- newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys)
 493                         -- This call to dataConInstOrigArgTys won't work for existentials
 494                         -- but existentials don't have record types anyway
 495                         ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
 496                                                 (dataConFieldLabels con) arg_ids
 497                               rhs = foldl (\a b -> nlHsApp a b)
 498                                           (nlHsTyApp (dataConWrapId con) out_inst_tys)
 499                                           val_args
 500                               pat = mkPrefixConPat con (map nlVarPat arg_ids) in_ty
 501
 502                         ; return (mkSimpleMatch [pat] rhs) }
 503
 504         -- It's important to generate the match with matchWrapper,
 505         -- and the right hand sides with applications of the wrapper Id
 506         -- so that everything works when we are doing fancy unboxing on the
 507         -- constructor aguments.
 508         ; alts <- mapM mk_alt cons_to_upd
 509         ; ([discrim_var], matching_code) <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
 510
 511         ; return (bindNonRec discrim_var record_expr' matching_code) }
 512 \end{code}
 513
 514 Here is where we desugar the Template Haskell brackets and escapes
 515
 516 \begin{code}
 517 -- Template Haskell stuff
 518
 519 #ifdef GHCI     /* Only if bootstrapping */
 520 dsExpr (HsBracketOut x ps) = dsBracket x ps
 521 dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
 522 #endif
 523
 524 -- Arrow notation extension
 525 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
 526 \end{code}
 527
 528 Hpc Support
 529
 530 \begin{code}
 531 dsExpr (HsTick ix vars e) = do
 532   e' <- dsLExpr e
 533   mkTickBox ix vars e'
 534
 535 -- There is a problem here. The then and else branches
 536 -- have no free variables, so they are open to lifting.
 537 -- We need someway of stopping this.
 538 -- This will make no difference to binary coverage
 539 -- (did you go here: YES or NO), but will effect accurate
 540 -- tick counting.
 541
 542 dsExpr (HsBinTick ixT ixF e) = do
 543   e2 <- dsLExpr e
 544   do { ASSERT(exprType e2 `coreEqType` boolTy)
 545        mkBinaryTickBox ixT ixF e2
 546      }
 547 \end{code}
 548
 549 \begin{code}
 550
 551 #ifdef DEBUG
 552 -- HsSyn constructs that just shouldn't be here:
 553 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
 554 #endif
 555
 556
 557 findField :: [HsRecField Id arg] -> Name -> [arg]
 558 findField rbinds lbl
 559   = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
 560          , lbl == idName (unLoc id) ]
 561 \end{code}
 562
 563 %--------------------------------------------------------------------
 564
 565 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
 566 handled in DsListComp).  Basically does the translation given in the
 567 Haskell 98 report:
 568
 569 \begin{code}
 570 dsDo    :: [LStmt Id]
 571         -> LHsExpr Id
 572         -> Type                 -- Type of the whole expression
 573         -> DsM CoreExpr
 574
 575 dsDo stmts body result_ty
 576   = go (map unLoc stmts)
 577   where
 578     go [] = dsLExpr body
 579
 580     go (ExprStmt rhs then_expr _ : stmts)
 581       = do { rhs2 <- dsLExpr rhs
 582            ; then_expr2 <- dsExpr then_expr
 583            ; rest <- go stmts
 584            ; returnDs (mkApps then_expr2 [rhs2, rest]) }
 585
 586     go (LetStmt binds : stmts)
 587       = do { rest <- go stmts
 588            ; dsLocalBinds binds rest }
 589
 590     go (BindStmt pat rhs bind_op fail_op : stmts)
 591       =
 592        do { body  <- go stmts
 593            ; var   <- selectSimpleMatchVarL pat
 594            ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
 595                                   result_ty (cantFailMatchResult body)
 596            ; match_code <- handle_failure pat match fail_op
 597            ; rhs'       <- dsLExpr rhs
 598            ; bind_op'   <- dsExpr bind_op
 599            ; returnDs (mkApps bind_op' [rhs', Lam var match_code]) }
 600
 601     -- In a do expression, pattern-match failure just calls
 602     -- the monadic 'fail' rather than throwing an exception
 603     handle_failure pat match fail_op
 604       | matchCanFail match
 605       = do { fail_op' <- dsExpr fail_op
 606            ; fail_msg <- mkStringExpr (mk_fail_msg pat)
 607            ; extractMatchResult match (App fail_op' fail_msg) }
 608       | otherwise
 609       = extractMatchResult match (error "It can't fail")
 610
 611 mk_fail_msg pat = "Pattern match failure in do expression at " ++
 612                   showSDoc (ppr (getLoc pat))
 613 \end{code}
 614
 615 Translation for RecStmt's:
 616 -----------------------------
 617 We turn (RecStmt [v1,..vn] stmts) into:
 618
 619   (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
 620                                       return (v1,..vn))
 621
 622 \begin{code}
 623 dsMDo   :: PostTcTable
 624         -> [LStmt Id]
 625         -> LHsExpr Id
 626         -> Type                 -- Type of the whole expression
 627         -> DsM CoreExpr
 628
 629 dsMDo tbl stmts body result_ty
 630   = go (map unLoc stmts)
 631   where
 632     (m_ty, b_ty) = tcSplitAppTy result_ty       -- result_ty must be of the form (m b)
 633     mfix_id   = lookupEvidence tbl mfixName
 634     return_id = lookupEvidence tbl returnMName
 635     bind_id   = lookupEvidence tbl bindMName
 636     then_id   = lookupEvidence tbl thenMName
 637     fail_id   = lookupEvidence tbl failMName
 638     ctxt      = MDoExpr tbl
 639
 640     go [] = dsLExpr body
 641
 642     go (LetStmt binds : stmts)
 643       = do { rest <- go stmts
 644            ; dsLocalBinds binds rest }
 645
 646     go (ExprStmt rhs _ rhs_ty : stmts)
 647       = do { rhs2 <- dsLExpr rhs
 648            ; rest <- go stmts
 649            ; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
 650
 651     go (BindStmt pat rhs _ _ : stmts)
 652       = do { body  <- go stmts
 653            ; var   <- selectSimpleMatchVarL pat
 654            ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
 655                                   result_ty (cantFailMatchResult body)
 656            ; fail_msg   <- mkStringExpr (mk_fail_msg pat)
 657            ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
 658            ; match_code <- extractMatchResult match fail_expr
 659
 660            ; rhs'       <- dsLExpr rhs
 661            ; returnDs (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
 662                                              rhs', Lam var match_code]) }
 663
 664     go (RecStmt rec_stmts later_ids rec_ids rec_rets binds : stmts)
 665       = ASSERT( length rec_ids > 0 )
 666         ASSERT( length rec_ids == length rec_rets )
 667         go (new_bind_stmt : let_stmt : stmts)
 668       where
 669         new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
 670         let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
 671
 672
 673                 -- Remove the later_ids that appear (without fancy coercions)
 674                 -- in rec_rets, because there's no need to knot-tie them separately
 675                 -- See Note [RecStmt] in HsExpr
 676         later_ids'   = filter (`notElem` mono_rec_ids) later_ids
 677         mono_rec_ids = [ id | HsVar id <- rec_rets ]
 678
 679         mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
 680         mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
 681                                              (mkFunTy tup_ty body_ty))
 682
 683         -- The rec_tup_pat must bind the rec_ids only; remember that the
 684         --      trimmed_laters may share the same Names
 685         -- Meanwhile, the later_pats must bind the later_vars
 686         rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
 687         later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
 688         rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
 689
 690         mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
 691         body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
 692         body_ty = mkAppTy m_ty tup_ty
 693         tup_ty  = mkCoreTupTy (map idType (later_ids' ++ rec_ids))
 694                   -- mkCoreTupTy deals with singleton case
 695
 696         return_app  = nlHsApp (nlHsTyApp return_id [tup_ty])
 697                               (mk_ret_tup rets)
 698
 699         mk_wild_pat :: Id -> LPat Id
 700         mk_wild_pat v = noLoc $ WildPat $ idType v
 701
 702         mk_later_pat :: Id -> LPat Id
 703         mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
 704                        | otherwise           = nlVarPat v
 705
 706         mk_tup_pat :: [LPat Id] -> LPat Id
 707         mk_tup_pat [p] = p
 708         mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
 709
 710         mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
 711         mk_ret_tup [r] = r
 712         mk_ret_tup rs  = noLoc $ ExplicitTuple rs Boxed
 713 \end{code}