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