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