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 -fno-warn-incomplete-patterns #-}
  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/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
  17
  18 #include "HsVersions.h"
  19
  20 import Match
  21 import MatchLit
  22 import DsBinds
  23 import DsGRHSs
  24 import DsListComp
  25 import DsUtils
  26 import DsArrows
  27 import DsMonad
  28 import Name
  29 import NameEnv
  30
  31 #ifdef GHCI
  32         -- Template Haskell stuff iff bootstrapped
  33 import DsMeta
  34 #endif
  35
  36 import HsSyn
  37 import TcHsSyn
  38
  39 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
  40 --     needs to see source types
  41 import TcType
  42 import Type
  43 import Coercion
  44 import CoreSyn
  45 import CoreUtils
  46 import CoreFVs
  47 import MkCore
  48
  49 import DynFlags
  50 import StaticFlags
  51 import CostCentre
  52 import Id
  53 import Var
  54 import VarSet
  55 import DataCon
  56 import TysWiredIn
  57 import BasicTypes
  58 import PrelNames
  59 import Maybes
  60 import SrcLoc
  61 import Util
  62 import Bag
  63 import Outputable
  64 import FastString
  65
  66 import Control.Monad
  67 \end{code}
  68
  69
  70 %************************************************************************
  71 %*                                                                      *
  72                 dsLocalBinds, dsValBinds
  73 %*                                                                      *
  74 %************************************************************************
  75
  76 \begin{code}
  77 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
  78 dsLocalBinds EmptyLocalBinds    body = return body
  79 dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
  80 dsLocalBinds (HsIPBinds binds)  body = dsIPBinds  binds body
  81
  82 -------------------------
  83 dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
  84 dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
  85
  86 -------------------------
  87 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
  88 dsIPBinds (IPBinds ip_binds ev_binds) body
  89   = do  { ds_ev_binds <- dsTcEvBinds ev_binds
  90         ; let inner = wrapDsEvBinds ds_ev_binds body
  91                 -- The dict bindings may not be in
  92                 -- dependency order; hence Rec
  93         ; foldrM ds_ip_bind inner ip_binds }
  94   where
  95     ds_ip_bind (L _ (IPBind n e)) body
  96       = do e' <- dsLExpr e
  97            return (Let (NonRec (ipNameName n) e') body)
  98
  99 -------------------------
 100 ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
 101 -- Special case for bindings which bind unlifted variables
 102 -- We need to do a case right away, rather than building
 103 -- a tuple and doing selections.
 104 -- Silently ignore INLINE and SPECIALISE pragmas...
 105 ds_val_bind (NonRecursive, hsbinds) body
 106   | [L loc bind] <- bagToList hsbinds,
 107         -- Non-recursive, non-overloaded bindings only come in ones
 108         -- ToDo: in some bizarre case it's conceivable that there
 109         --       could be dict binds in the 'binds'.  (See the notes
 110         --       below.  Then pattern-match would fail.  Urk.)
 111     strictMatchOnly bind
 112   = putSrcSpanDs loc (dsStrictBind bind body)
 113
 114 -- Ordinary case for bindings; none should be unlifted
 115 ds_val_bind (_is_rec, binds) body
 116   = do  { prs <- dsLHsBinds binds
 117         ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
 118           case prs of
 119             [] -> return body
 120             _  -> return (Let (Rec prs) body) }
 121         -- Use a Rec regardless of is_rec.
 122         -- Why? Because it allows the binds to be all
 123         -- mixed up, which is what happens in one rare case
 124         -- Namely, for an AbsBind with no tyvars and no dicts,
 125         --         but which does have dictionary bindings.
 126         -- See notes with TcSimplify.inferLoop [NO TYVARS]
 127         -- It turned out that wrapping a Rec here was the easiest solution
 128         --
 129         -- NB The previous case dealt with unlifted bindings, so we
 130         --    only have to deal with lifted ones now; so Rec is ok
 131
 132 ------------------
 133 dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
 134 dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
 135                , abs_exports = exports
 136                , abs_ev_binds = ev_binds
 137                , abs_binds = binds }) body
 138   = do { ds_ev_binds <- dsTcEvBinds ev_binds
 139        ; let body1 = foldr bind_export body exports
 140              bind_export (_, g, l, _) b = bindNonRec g (Var l) b
 141        ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body)
 142                             body1 binds
 143        ; return (wrapDsEvBinds ds_ev_binds body2) }
 144
 145 dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
 146                       , fun_tick = tick, fun_infix = inf }) body
 147                 -- Can't be a bang pattern (that looks like a PatBind)
 148                 -- so must be simply unboxed
 149   = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
 150        ; MASSERT( null args ) -- Functions aren't lifted
 151        ; MASSERT( isIdHsWrapper co_fn )
 152        ; rhs' <- mkOptTickBox tick rhs
 153        ; return (bindNonRec fun rhs' body) }
 154
 155 dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
 156   =     -- let C x# y# = rhs in body
 157         -- ==> case rhs of C x# y# -> body
 158     do { rhs <- dsGuarded grhss ty
 159        ; let upat = unLoc pat
 160              eqn = EqnInfo { eqn_pats = [upat],
 161                              eqn_rhs = cantFailMatchResult body }
 162        ; var    <- selectMatchVar upat
 163        ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
 164        ; return (scrungleMatch var rhs result) }
 165
 166 dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
 167
 168 ----------------------
 169 strictMatchOnly :: HsBind Id -> Bool
 170 strictMatchOnly (AbsBinds { abs_binds = binds })
 171   = anyBag (strictMatchOnly . unLoc) binds
 172 strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
 173   =  isUnboxedTupleType ty
 174   || isBangLPat lpat
 175   || any (isUnLiftedType . idType) (collectPatBinders lpat)
 176 strictMatchOnly (FunBind { fun_id = L _ id })
 177   = isUnLiftedType (idType id)
 178 strictMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
 179
 180 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 181 -- Returns something like (let var = scrut in body)
 182 -- but if var is an unboxed-tuple type, it inlines it in a fragile way
 183 -- Special case to handle unboxed tuple patterns; they can't appear nested
 184 -- The idea is that
 185 --      case e of (# p1, p2 #) -> rhs
 186 -- should desugar to
 187 --      case e of (# x1, x2 #) -> ... match p1, p2 ...
 188 -- NOT
 189 --      let x = e in case x of ....
 190 --
 191 -- But there may be a big
 192 --      let fail = ... in case e of ...
 193 -- wrapping the whole case, which complicates matters slightly
 194 -- It all seems a bit fragile.  Test is dsrun013.
 195
 196 scrungleMatch var scrut body
 197   | isUnboxedTupleType (idType var) = scrungle body
 198   | otherwise                       = bindNonRec var scrut body
 199   where
 200     scrungle (Case (Var x) bndr ty alts)
 201                     | x == var = Case scrut bndr ty alts
 202     scrungle (Let binds body)  = Let binds (scrungle body)
 203     scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
 204
 205 \end{code}
 206
 207 %************************************************************************
 208 %*                                                                      *
 209 \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
 210 %*                                                                      *
 211 %************************************************************************
 212
 213 \begin{code}
 214 dsLExpr :: LHsExpr Id -> DsM CoreExpr
 215
 216 dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
 217
 218 dsExpr :: HsExpr Id -> DsM CoreExpr
 219 dsExpr (HsPar e)              = dsLExpr e
 220 dsExpr (ExprWithTySigOut e _) = dsLExpr e
 221 dsExpr (HsVar var)            = return (Var var)
 222 dsExpr (HsIPVar ip)           = return (Var (ipNameName ip))
 223 dsExpr (HsLit lit)            = dsLit lit
 224 dsExpr (HsOverLit lit)        = dsOverLit lit
 225 dsExpr (HsWrap co_fn e)       = do { co_fn' <- dsHsWrapper co_fn
 226                                    ; e' <- dsExpr e
 227                                    ; return (co_fn' e') }
 228
 229 dsExpr (NegApp expr neg_expr)
 230   = App <$> dsExpr neg_expr <*> dsLExpr expr
 231
 232 dsExpr (HsLam a_Match)
 233   = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
 234
 235 dsExpr (HsApp fun arg)
 236   = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
 237 \end{code}
 238
 239 Operator sections.  At first it looks as if we can convert
 240 \begin{verbatim}
 241         (expr op)
 242 \end{verbatim}
 243 to
 244 \begin{verbatim}
 245         \x -> op expr x
 246 \end{verbatim}
 247
 248 But no!  expr might be a redex, and we can lose laziness badly this
 249 way.  Consider
 250 \begin{verbatim}
 251         map (expr op) xs
 252 \end{verbatim}
 253 for example.  So we convert instead to
 254 \begin{verbatim}
 255         let y = expr in \x -> op y x
 256 \end{verbatim}
 257 If \tr{expr} is actually just a variable, say, then the simplifier
 258 will sort it out.
 259
 260 \begin{code}
 261 dsExpr (OpApp e1 op _ e2)
 262   = -- for the type of y, we need the type of op's 2nd argument
 263     mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
 264
 265 dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
 266   = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
 267
 268 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
 269 dsExpr (SectionR op expr) = do
 270     core_op <- dsLExpr op
 271     -- for the type of x, we need the type of op's 2nd argument
 272     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
 273         -- See comment with SectionL
 274     y_core <- dsLExpr expr
 275     x_id <- newSysLocalDs x_ty
 276     y_id <- newSysLocalDs y_ty
 277     return (bindNonRec y_id y_core $
 278             Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
 279
 280 dsExpr (ExplicitTuple tup_args boxity)
 281   = do { let go (lam_vars, args) (Missing ty)
 282                     -- For every missing expression, we need
 283                     -- another lambda in the desugaring.
 284                = do { lam_var <- newSysLocalDs ty
 285                     ; return (lam_var : lam_vars, Var lam_var : args) }
 286              go (lam_vars, args) (Present expr)
 287                     -- Expressions that are present don't generate
 288                     -- lambdas, just arguments.
 289                = do { core_expr <- dsLExpr expr
 290                     ; return (lam_vars, core_expr : args) }
 291
 292        ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
 293                 -- The reverse is because foldM goes left-to-right
 294
 295        ; return $ mkCoreLams lam_vars $
 296                   mkConApp (tupleCon boxity (length tup_args))
 297                            (map (Type . exprType) args ++ args) }
 298
 299 dsExpr (HsSCC cc expr) = do
 300     mod_name <- getModuleDs
 301     Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
 302
 303 dsExpr (HsCoreAnn fs expr)
 304   = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
 305
 306 dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
 307   | isEmptyMatchGroup matches   -- A Core 'case' is always non-empty
 308   =                             -- So desugar empty HsCase to error call
 309     mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
 310
 311   | otherwise
 312   = do { core_discrim <- dsLExpr discrim
 313        ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
 314        ; return (scrungleMatch discrim_var core_discrim matching_code) }
 315
 316 -- Pepe: The binds are in scope in the body but NOT in the binding group
 317 --       This is to avoid silliness in breakpoints
 318 dsExpr (HsLet binds body) = do
 319     body' <- dsLExpr body
 320     dsLocalBinds binds body'
 321
 322 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
 323 -- because the interpretation of `stmts' depends on what sort of thing it is.
 324 --
 325 dsExpr (HsDo ListComp stmts body result_ty)
 326   =     -- Special case for list comprehensions
 327     dsListComp stmts body elt_ty
 328   where
 329     [elt_ty] = tcTyConAppArgs result_ty
 330
 331 dsExpr (HsDo DoExpr stmts body result_ty)
 332   = dsDo stmts body result_ty
 333
 334 dsExpr (HsDo GhciStmt stmts body result_ty)
 335   = dsDo stmts body result_ty
 336
 337 dsExpr (HsDo ctxt@(MDoExpr tbl) stmts body result_ty)
 338   = do { (meth_binds, tbl') <- dsSyntaxTable tbl
 339        ; core_expr <- dsMDo ctxt tbl' stmts body result_ty
 340        ; return (mkLets meth_binds core_expr) }
 341
 342 dsExpr (HsDo PArrComp stmts body result_ty)
 343   =     -- Special case for array comprehensions
 344     dsPArrComp (map unLoc stmts) body elt_ty
 345   where
 346     [elt_ty] = tcTyConAppArgs result_ty
 347
 348 dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
 349   = do { pred <- dsLExpr guard_expr
 350        ; b1 <- dsLExpr then_expr
 351        ; b2 <- dsLExpr else_expr
 352        ; case mb_fun of
 353            Just fun -> do { core_fun <- dsExpr fun
 354                           ; return (mkCoreApps core_fun [pred,b1,b2]) }
 355            Nothing  -> return $ mkIfThenElse pred b1 b2 }
 356 \end{code}
 357
 358
 359 \noindent
 360 \underline{\bf Various data construction things}
 361 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 362 \begin{code}
 363 dsExpr (ExplicitList elt_ty xs)
 364   = dsExplicitList elt_ty xs
 365
 366 -- We desugar [:x1, ..., xn:] as
 367 --   singletonP x1 +:+ ... +:+ singletonP xn
 368 --
 369 dsExpr (ExplicitPArr ty []) = do
 370     emptyP <- dsLookupGlobalId emptyPName
 371     return (Var emptyP `App` Type ty)
 372 dsExpr (ExplicitPArr ty xs) = do
 373     singletonP <- dsLookupGlobalId singletonPName
 374     appP       <- dsLookupGlobalId appPName
 375     xs'        <- mapM dsLExpr xs
 376     return . foldr1 (binary appP) $ map (unary singletonP) xs'
 377   where
 378     unary  fn x   = mkApps (Var fn) [Type ty, x]
 379     binary fn x y = mkApps (Var fn) [Type ty, x, y]
 380
 381 dsExpr (ArithSeq expr (From from))
 382   = App <$> dsExpr expr <*> dsLExpr from
 383
 384 dsExpr (ArithSeq expr (FromTo from to))
 385   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
 386
 387 dsExpr (ArithSeq expr (FromThen from thn))
 388   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
 389
 390 dsExpr (ArithSeq expr (FromThenTo from thn to))
 391   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
 392
 393 dsExpr (PArrSeq expr (FromTo from to))
 394   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
 395
 396 dsExpr (PArrSeq expr (FromThenTo from thn to))
 397   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
 398
 399 dsExpr (PArrSeq _ _)
 400   = panic "DsExpr.dsExpr: Infinite parallel array!"
 401     -- the parser shouldn't have generated it and the renamer and typechecker
 402     -- shouldn't have let it through
 403 \end{code}
 404
 405 \noindent
 406 \underline{\bf Record construction and update}
 407 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 408 For record construction we do this (assuming T has three arguments)
 409 \begin{verbatim}
 410         T { op2 = e }
 411 ==>
 412         let err = /\a -> recConErr a
 413         T (recConErr t1 "M.lhs/230/op1")
 414           e
 415           (recConErr t1 "M.lhs/230/op3")
 416 \end{verbatim}
 417 @recConErr@ then converts its arugment string into a proper message
 418 before printing it as
 419 \begin{verbatim}
 420         M.lhs, line 230: missing field op1 was evaluated
 421 \end{verbatim}
 422
 423 We also handle @C{}@ as valid construction syntax for an unlabelled
 424 constructor @C@, setting all of @C@'s fields to bottom.
 425
 426 \begin{code}
 427 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
 428     con_expr' <- dsExpr con_expr
 429     let
 430         (arg_tys, _) = tcSplitFunTys (exprType con_expr')
 431         -- A newtype in the corner should be opaque;
 432         -- hence TcType.tcSplitFunTys
 433
 434         mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
 435           = case findField (rec_flds rbinds) lbl of
 436               (rhs:rhss) -> ASSERT( null rhss )
 437                             dsLExpr rhs
 438               []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
 439         unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
 440
 441         labels = dataConFieldLabels (idDataCon data_con_id)
 442         -- The data_con_id is guaranteed to be the wrapper id of the constructor
 443
 444     con_args <- if null labels
 445                 then mapM unlabelled_bottom arg_tys
 446                 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
 447
 448     return (mkApps con_expr' con_args)
 449 \end{code}
 450
 451 Record update is a little harder. Suppose we have the decl:
 452 \begin{verbatim}
 453         data T = T1 {op1, op2, op3 :: Int}
 454                | T2 {op4, op2 :: Int}
 455                | T3
 456 \end{verbatim}
 457 Then we translate as follows:
 458 \begin{verbatim}
 459         r { op2 = e }
 460 ===>
 461         let op2 = e in
 462         case r of
 463           T1 op1 _ op3 -> T1 op1 op2 op3
 464           T2 op4 _     -> T2 op4 op2
 465           other        -> recUpdError "M.lhs/230"
 466 \end{verbatim}
 467 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
 468 RHSs, and do not generate a Core constructor application directly, because the constructor
 469 might do some argument-evaluation first; and may have to throw away some
 470 dictionaries.
 471
 472 Note [Update for GADTs]
 473 ~~~~~~~~~~~~~~~~~~~~~~~
 474 Consider
 475    data T a b where
 476      T1 { f1 :: a } :: T a Int
 477
 478 Then the wrapper function for T1 has type
 479    $WT1 :: a -> T a Int
 480 But if x::T a b, then
 481    x { f1 = v } :: T a b   (not T a Int!)
 482 So we need to cast (T a Int) to (T a b).  Sigh.
 483
 484 \begin{code}
 485 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
 486                        cons_to_upd in_inst_tys out_inst_tys)
 487   | null fields
 488   = dsLExpr record_expr
 489   | otherwise
 490   = ASSERT2( notNull cons_to_upd, ppr expr )
 491
 492     do  { record_expr' <- dsLExpr record_expr
 493         ; field_binds' <- mapM ds_field fields
 494         ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
 495               upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
 496
 497         -- It's important to generate the match with matchWrapper,
 498         -- and the right hand sides with applications of the wrapper Id
 499         -- so that everything works when we are doing fancy unboxing on the
 500         -- constructor aguments.
 501         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
 502         ; ([discrim_var], matching_code)
 503                 <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
 504
 505         ; return (add_field_binds field_binds' $
 506                   bindNonRec discrim_var record_expr' matching_code) }
 507   where
 508     ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
 509       -- Clone the Id in the HsRecField, because its Name is that
 510       -- of the record selector, and we must not make that a lcoal binder
 511       -- else we shadow other uses of the record selector
 512       -- Hence 'lcl_id'.  Cf Trac #2735
 513     ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
 514                             ; let fld_id = unLoc (hsRecFieldId rec_field)
 515                             ; lcl_id <- newSysLocalDs (idType fld_id)
 516                             ; return (idName fld_id, lcl_id, rhs) }
 517
 518     add_field_binds [] expr = expr
 519     add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
 520
 521         -- Awkwardly, for families, the match goes
 522         -- from instance type to family type
 523     tycon     = dataConTyCon (head cons_to_upd)
 524     in_ty     = mkTyConApp tycon in_inst_tys
 525     in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
 526
 527     mk_alt upd_fld_env con
 528       = do { let (univ_tvs, ex_tvs, eq_spec,
 529                   eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
 530                  subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
 531
 532                 -- I'm not bothering to clone the ex_tvs
 533            ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
 534            ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
 535            ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
 536            ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
 537                                          (dataConFieldLabels con) arg_ids
 538                  mk_val_arg field_name pat_arg_id
 539                      = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
 540                  inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
 541                         -- Reconstruct with the WrapId so that unpacking happens
 542                  wrap = mkWpEvVarApps theta_vars          `WpCompose`
 543                         mkWpTyApps    (mkTyVarTys ex_tvs) `WpCompose`
 544                         mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
 545                                        , isNothing (lookupTyVar wrap_subst tv) ]
 546                  rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
 547
 548                         -- Tediously wrap the application in a cast
 549                         -- Note [Update for GADTs]
 550                  wrapped_rhs | null eq_spec = rhs
 551                              | otherwise    = mkLHsWrap (WpCast wrap_co) rhs
 552                  wrap_co = mkTyConApp tycon [ lookup tv ty
 553                                             | (tv,ty) <- univ_tvs `zip` out_inst_tys]
 554                  lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
 555                                         Just ty' -> ty'
 556                                         Nothing  -> ty
 557                  wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
 558                                            | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
 559
 560                  pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
 561                                          , pat_dicts = eqs_vars ++ theta_vars
 562                                          , pat_binds = emptyTcEvBinds
 563                                          , pat_args = PrefixCon $ map nlVarPat arg_ids
 564                                          , pat_ty = in_ty }
 565            ; return (mkSimpleMatch [pat] wrapped_rhs) }
 566
 567 \end{code}
 568
 569 Here is where we desugar the Template Haskell brackets and escapes
 570
 571 \begin{code}
 572 -- Template Haskell stuff
 573
 574 #ifdef GHCI     /* Only if bootstrapping */
 575 dsExpr (HsBracketOut x ps) = dsBracket x ps
 576 dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
 577 #endif
 578
 579 -- Arrow notation extension
 580 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
 581 \end{code}
 582
 583 Hpc Support
 584
 585 \begin{code}
 586 dsExpr (HsTick ix vars e) = do
 587   e' <- dsLExpr e
 588   mkTickBox ix vars e'
 589
 590 -- There is a problem here. The then and else branches
 591 -- have no free variables, so they are open to lifting.
 592 -- We need someway of stopping this.
 593 -- This will make no difference to binary coverage
 594 -- (did you go here: YES or NO), but will effect accurate
 595 -- tick counting.
 596
 597 dsExpr (HsBinTick ixT ixF e) = do
 598   e2 <- dsLExpr e
 599   do { ASSERT(exprType e2 `coreEqType` boolTy)
 600        mkBinaryTickBox ixT ixF e2
 601      }
 602 \end{code}
 603
 604 \begin{code}
 605
 606 -- HsSyn constructs that just shouldn't be here:
 607 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
 608
 609
 610 findField :: [HsRecField Id arg] -> Name -> [arg]
 611 findField rbinds lbl
 612   = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
 613          , lbl == idName (unLoc id) ]
 614 \end{code}
 615
 616 %--------------------------------------------------------------------
 617
 618 Note [Desugaring explicit lists]
 619 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 620 Explicit lists are desugared in a cleverer way to prevent some
 621 fruitless allocations.  Essentially, whenever we see a list literal
 622 [x_1, ..., x_n] we:
 623
 624 1. Find the tail of the list that can be allocated statically (say
 625    [x_k, ..., x_n]) by later stages and ensure we desugar that
 626    normally: this makes sure that we don't cause a code size increase
 627    by having the cons in that expression fused (see later) and hence
 628    being unable to statically allocate any more
 629
 630 2. For the prefix of the list which cannot be allocated statically,
 631    say [x_1, ..., x_(k-1)], we turn it into an expression involving
 632    build so that if we find any foldrs over it it will fuse away
 633    entirely!
 634
 635    So in this example we will desugar to:
 636    build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
 637
 638    If fusion fails to occur then build will get inlined and (since we
 639    defined a RULE for foldr (:) []) we will get back exactly the
 640    normal desugaring for an explicit list.
 641
 642 This optimisation can be worth a lot: up to 25% of the total
 643 allocation in some nofib programs. Specifically
 644
 645         Program           Size    Allocs   Runtime  CompTime
 646         rewrite          +0.0%    -26.3%      0.02     -1.8%
 647            ansi          -0.3%    -13.8%      0.00     +0.0%
 648            lift          +0.0%     -8.7%      0.00     -2.3%
 649
 650 Of course, if rules aren't turned on then there is pretty much no
 651 point doing this fancy stuff, and it may even be harmful.
 652
 653 =======>  Note by SLPJ Dec 08.
 654
 655 I'm unconvinced that we should *ever* generate a build for an explicit
 656 list.  See the comments in GHC.Base about the foldr/cons rule, which
 657 points out that (foldr k z [a,b,c]) may generate *much* less code than
 658 (a `k` b `k` c `k` z).
 659
 660 Furthermore generating builds messes up the LHS of RULES.
 661 Example: the foldr/single rule in GHC.Base
 662    foldr k z [x] = ...
 663 We do not want to generate a build invocation on the LHS of this RULE!
 664
 665 We fix this by disabling rules in rule LHSs, and testing that
 666 flag here; see Note [Desugaring RULE left hand sides] in Desugar
 667
 668 To test this I've added a (static) flag -fsimple-list-literals, which
 669 makes all list literals be generated via the simple route.
 670
 671
 672 \begin{code}
 673 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
 674 -- See Note [Desugaring explicit lists]
 675 dsExplicitList elt_ty xs
 676   = do { dflags <- getDOptsDs
 677        ; xs' <- mapM dsLExpr xs
 678        ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
 679        ; if opt_SimpleListLiterals                      -- -fsimple-list-literals
 680          || not (dopt Opt_EnableRewriteRules dflags)    -- Rewrite rules off
 681                 -- Don't generate a build if there are no rules to eliminate it!
 682                 -- See Note [Desugaring RULE left hand sides] in Desugar
 683          || null dynamic_prefix   -- Avoid build (\c n. foldr c n xs)!
 684          then return $ mkListExpr elt_ty xs'
 685          else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
 686   where
 687     is_static :: CoreExpr -> Bool
 688     is_static e = all is_static_var (varSetElems (exprFreeVars e))
 689
 690     is_static_var :: Var -> Bool
 691     is_static_var v
 692       | isId v = isExternalName (idName v)  -- Top-level things are given external names
 693       | otherwise = False                   -- Type variables
 694
 695     mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
 696       = do { let suffix' = mkListExpr elt_ty suffix
 697            ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
 698            ; return (foldr (App . App (Var c)) folded_suffix prefix) }
 699
 700 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
 701 spanTail f xs = (reverse rejected, reverse satisfying)
 702     where (satisfying, rejected) = span f $ reverse xs
 703 \end{code}
 704
 705 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
 706 handled in DsListComp).  Basically does the translation given in the
 707 Haskell 98 report:
 708
 709 \begin{code}
 710 dsDo    :: [LStmt Id]
 711         -> LHsExpr Id
 712         -> Type                 -- Type of the whole expression
 713         -> DsM CoreExpr
 714
 715 dsDo stmts body result_ty
 716   = goL stmts
 717   where
 718     -- result_ty must be of the form (m b)
 719     (m_ty, _b_ty) = tcSplitAppTy result_ty
 720
 721     goL [] = dsLExpr body
 722     goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
 723
 724     go _ (ExprStmt rhs then_expr _) stmts
 725       = do { rhs2 <- dsLExpr rhs
 726            ; case tcSplitAppTy_maybe (exprType rhs2) of
 727                 Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
 728                 _                                 -> return ()
 729            ; then_expr2 <- dsExpr then_expr
 730            ; rest <- goL stmts
 731            ; return (mkApps then_expr2 [rhs2, rest]) }
 732
 733     go _ (LetStmt binds) stmts
 734       = do { rest <- goL stmts
 735            ; dsLocalBinds binds rest }
 736
 737     go _ (BindStmt pat rhs bind_op fail_op) stmts
 738       = do  { body     <- goL stmts
 739             ; rhs'     <- dsLExpr rhs
 740             ; bind_op' <- dsExpr bind_op
 741             ; var   <- selectSimpleMatchVarL pat
 742             ; let bind_ty = exprType bind_op'   -- rhs -> (pat -> res1) -> res2
 743                   res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
 744             ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
 745                                       res1_ty (cantFailMatchResult body)
 746             ; match_code <- handle_failure pat match fail_op
 747             ; return (mkApps bind_op' [rhs', Lam var match_code]) }
 748
 749     go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
 750                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op
 751                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
 752                     , recS_rec_rets = rec_rets, recS_dicts = _ev_binds }) stmts
 753       = ASSERT( length rec_ids > 0 )
 754         ASSERT( isEmptyTcEvBinds _ev_binds )   -- No method binds
 755         goL (new_bind_stmt : stmts)
 756       where
 757         -- returnE <- dsExpr return_id
 758         -- mfixE <- dsExpr mfix_id
 759         new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
 760                                          bind_op
 761                                              noSyntaxExpr  -- Tuple cannot fail
 762
 763         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
 764         rec_tup_pats = map nlVarPat tup_ids
 765         later_pats   = rec_tup_pats
 766         rets         = map noLoc rec_rets
 767
 768         mfix_app   = nlHsApp (noLoc mfix_op) mfix_arg
 769         mfix_arg   = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
 770                                              (mkFunTy tup_ty body_ty))
 771         mfix_pat   = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
 772         body       = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
 773         return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
 774         body_ty    = mkAppTy m_ty tup_ty
 775         tup_ty     = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
 776
 777     -- In a do expression, pattern-match failure just calls
 778     -- the monadic 'fail' rather than throwing an exception
 779     handle_failure pat match fail_op
 780       | matchCanFail match
 781       = do { fail_op' <- dsExpr fail_op
 782            ; fail_msg <- mkStringExpr (mk_fail_msg pat)
 783            ; extractMatchResult match (App fail_op' fail_msg) }
 784       | otherwise
 785       = extractMatchResult match (error "It can't fail")
 786
 787 mk_fail_msg :: Located e -> String
 788 mk_fail_msg pat = "Pattern match failure in do expression at " ++
 789                   showSDoc (ppr (getLoc pat))
 790 \end{code}
 791
 792 Translation for RecStmt's:
 793 -----------------------------
 794 We turn (RecStmt [v1,..vn] stmts) into:
 795
 796   (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
 797                                       return (v1,..vn))
 798
 799 \begin{code}
 800 dsMDo   :: HsStmtContext Name
 801         -> [(Name,Id)]
 802         -> [LStmt Id]
 803         -> LHsExpr Id
 804         -> Type                 -- Type of the whole expression
 805         -> DsM CoreExpr
 806
 807 dsMDo ctxt tbl stmts body result_ty
 808   = goL stmts
 809   where
 810     goL [] = dsLExpr body
 811     goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
 812
 813     (m_ty, b_ty) = tcSplitAppTy result_ty       -- result_ty must be of the form (m b)
 814     mfix_id   = lookupEvidence tbl mfixName
 815     return_id = lookupEvidence tbl returnMName
 816     bind_id   = lookupEvidence tbl bindMName
 817     then_id   = lookupEvidence tbl thenMName
 818     fail_id   = lookupEvidence tbl failMName
 819
 820     go _ (LetStmt binds) stmts
 821       = do { rest <- goL stmts
 822            ; dsLocalBinds binds rest }
 823
 824     go _ (ExprStmt rhs _ rhs_ty) stmts
 825       = do { rhs2 <- dsLExpr rhs
 826            ; warnDiscardedDoBindings rhs m_ty rhs_ty
 827            ; rest <- goL stmts
 828            ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
 829
 830     go _ (BindStmt pat rhs _ _) stmts
 831       = do { body  <- goL stmts
 832            ; var   <- selectSimpleMatchVarL pat
 833            ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
 834                                   result_ty (cantFailMatchResult body)
 835            ; fail_msg   <- mkStringExpr (mk_fail_msg pat)
 836            ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
 837            ; match_code <- extractMatchResult match fail_expr
 838
 839            ; rhs'       <- dsLExpr rhs
 840            ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
 841                                              rhs', Lam var match_code]) }
 842
 843     go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
 844                     , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
 845                     , recS_dicts = _ev_binds }) stmts
 846       = ASSERT( length rec_ids > 0 )
 847         ASSERT( length rec_ids == length rec_rets )
 848         ASSERT( isEmptyTcEvBinds _ev_binds )
 849         pprTrace "dsMDo" (ppr later_ids) $
 850          goL (new_bind_stmt : stmts)
 851       where
 852         new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
 853
 854                 -- Remove the later_ids that appear (without fancy coercions)
 855                 -- in rec_rets, because there's no need to knot-tie them separately
 856                 -- See Note [RecStmt] in HsExpr
 857         later_ids'   = filter (`notElem` mono_rec_ids) later_ids
 858         mono_rec_ids = [ id | HsVar id <- rec_rets ]
 859
 860         mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
 861         mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
 862                                              (mkFunTy tup_ty body_ty))
 863
 864         -- The rec_tup_pat must bind the rec_ids only; remember that the
 865         --      trimmed_laters may share the same Names
 866         -- Meanwhile, the later_pats must bind the later_vars
 867         rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
 868         later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
 869         rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
 870
 871         mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
 872         body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
 873         body_ty = mkAppTy m_ty tup_ty
 874         tup_ty  = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids))  -- Deals with singleton case
 875
 876         return_app  = nlHsApp (nlHsTyApp return_id [tup_ty])
 877                               (mkLHsTupleExpr rets)
 878
 879         mk_wild_pat :: Id -> LPat Id
 880         mk_wild_pat v = noLoc $ WildPat $ idType v
 881
 882         mk_later_pat :: Id -> LPat Id
 883         mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
 884                        | otherwise           = nlVarPat v
 885
 886         mk_tup_pat :: [LPat Id] -> LPat Id
 887         mk_tup_pat [p] = p
 888         mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
 889 \end{code}
 890
 891
 892 %************************************************************************
 893 %*                                                                      *
 894 \subsection{Errors and contexts}
 895 %*                                                                      *
 896 %************************************************************************
 897
 898 \begin{code}
 899 -- Warn about certain types of values discarded in monadic bindings (#3263)
 900 warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
 901 warnDiscardedDoBindings rhs container_ty returning_ty = do {
 902           -- Warn about discarding non-() things in 'monadic' binding
 903         ; warn_unused <- doptDs Opt_WarnUnusedDoBind
 904         ; if warn_unused && not (returning_ty `tcEqType` unitTy)
 905            then warnDs (unusedMonadBind rhs returning_ty)
 906            else do {
 907           -- Warn about discarding m a things in 'monadic' binding of the same type,
 908           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
 909         ; warn_wrong <- doptDs Opt_WarnWrongDoBind
 910         ; case tcSplitAppTy_maybe returning_ty of
 911                   Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
 912                                                             warnDs (wrongMonadBind rhs returning_ty)
 913                   _ -> return () } }
 914
 915 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
 916 unusedMonadBind rhs returning_ty
 917   = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
 918     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
 919     ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
 920
 921 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
 922 wrongMonadBind rhs returning_ty
 923   = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
 924     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
 925     ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
 926 \end{code}