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