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