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 dsExpr (ExprWithTySigOut e _) = dsLExpr e
 220 dsExpr (HsVar var)            = return (Var var)
 221 dsExpr (HsIPVar ip)           = return (Var (ipNameName ip))
 222 dsExpr (HsLit lit)            = dsLit lit
 223 dsExpr (HsOverLit lit)        = dsOverLit lit
 224
 225 dsExpr (HsWrap co_fn e)
 226   = do { co_fn' <- dsHsWrapper co_fn
 227        ; e' <- dsExpr e
 228        ; warn_id <- doptDs Opt_WarnIdentities
 229        ; when warn_id $ warnAboutIdentities e' co_fn'
 230        ; return (co_fn' e') }
 231
 232 dsExpr (NegApp expr neg_expr)
 233   = App <$> dsExpr neg_expr <*> dsLExpr expr
 234
 235 dsExpr (HsLam a_Match)
 236   = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
 237
 238 dsExpr (HsApp fun arg)
 239   = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
 240 \end{code}
 241
 242 Operator sections.  At first it looks as if we can convert
 243 \begin{verbatim}
 244         (expr op)
 245 \end{verbatim}
 246 to
 247 \begin{verbatim}
 248         \x -> op expr x
 249 \end{verbatim}
 250
 251 But no!  expr might be a redex, and we can lose laziness badly this
 252 way.  Consider
 253 \begin{verbatim}
 254         map (expr op) xs
 255 \end{verbatim}
 256 for example.  So we convert instead to
 257 \begin{verbatim}
 258         let y = expr in \x -> op y x
 259 \end{verbatim}
 260 If \tr{expr} is actually just a variable, say, then the simplifier
 261 will sort it out.
 262
 263 \begin{code}
 264 dsExpr (OpApp e1 op _ e2)
 265   = -- for the type of y, we need the type of op's 2nd argument
 266     mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]
 267
 268 dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
 269   = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr
 270
 271 -- dsLExpr (SectionR op expr)   -- \ x -> op x expr
 272 dsExpr (SectionR op expr) = do
 273     core_op <- dsLExpr op
 274     -- for the type of x, we need the type of op's 2nd argument
 275     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
 276         -- See comment with SectionL
 277     y_core <- dsLExpr expr
 278     x_id <- newSysLocalDs x_ty
 279     y_id <- newSysLocalDs y_ty
 280     return (bindNonRec y_id y_core $
 281             Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
 282
 283 dsExpr (ExplicitTuple tup_args boxity)
 284   = do { let go (lam_vars, args) (Missing ty)
 285                     -- For every missing expression, we need
 286                     -- another lambda in the desugaring.
 287                = do { lam_var <- newSysLocalDs ty
 288                     ; return (lam_var : lam_vars, Var lam_var : args) }
 289              go (lam_vars, args) (Present expr)
 290                     -- Expressions that are present don't generate
 291                     -- lambdas, just arguments.
 292                = do { core_expr <- dsLExpr expr
 293                     ; return (lam_vars, core_expr : args) }
 294
 295        ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
 296                 -- The reverse is because foldM goes left-to-right
 297
 298        ; return $ mkCoreLams lam_vars $
 299                   mkConApp (tupleCon boxity (length tup_args))
 300                            (map (Type . exprType) args ++ args) }
 301
 302 dsExpr (HsSCC cc expr) = do
 303     mod_name <- getModuleDs
 304     Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
 305
 306 dsExpr (HsCoreAnn fs expr)
 307   = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
 308
 309 dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
 310   | isEmptyMatchGroup matches   -- A Core 'case' is always non-empty
 311   =                             -- So desugar empty HsCase to error call
 312     mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
 313
 314   | otherwise
 315   = do { core_discrim <- dsLExpr discrim
 316        ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
 317        ; return (scrungleMatch discrim_var core_discrim matching_code) }
 318
 319 -- Pepe: The binds are in scope in the body but NOT in the binding group
 320 --       This is to avoid silliness in breakpoints
 321 dsExpr (HsLet binds body) = do
 322     body' <- dsLExpr body
 323     dsLocalBinds binds body'
 324
 325 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
 326 -- because the interpretation of `stmts' depends on what sort of thing it is.
 327 --
 328 dsExpr (HsDo ListComp stmts body result_ty)
 329   =     -- Special case for list comprehensions
 330     dsListComp stmts body elt_ty
 331   where
 332     [elt_ty] = tcTyConAppArgs result_ty
 333
 334 dsExpr (HsDo DoExpr stmts body result_ty)
 335   = dsDo stmts body result_ty
 336
 337 dsExpr (HsDo GhciStmt stmts body result_ty)
 338   = dsDo stmts body result_ty
 339
 340 dsExpr (HsDo MDoExpr stmts body result_ty)
 341   = dsDo stmts body result_ty
 342
 343 dsExpr (HsDo PArrComp stmts body result_ty)
 344   =     -- Special case for array comprehensions
 345     dsPArrComp (map unLoc stmts) body elt_ty
 346   where
 347     [elt_ty] = tcTyConAppArgs result_ty
 348
 349 dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
 350   = do { pred <- dsLExpr guard_expr
 351        ; b1 <- dsLExpr then_expr
 352        ; b2 <- dsLExpr else_expr
 353        ; case mb_fun of
 354            Just fun -> do { core_fun <- dsExpr fun
 355                           ; return (mkCoreApps core_fun [pred,b1,b2]) }
 356            Nothing  -> return $ mkIfThenElse pred b1 b2 }
 357 \end{code}
 358
 359
 360 \noindent
 361 \underline{\bf Various data construction things}
 362 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 363 \begin{code}
 364 dsExpr (ExplicitList elt_ty xs)
 365   = dsExplicitList elt_ty xs
 366
 367 -- We desugar [:x1, ..., xn:] as
 368 --   singletonP x1 +:+ ... +:+ singletonP xn
 369 --
 370 dsExpr (ExplicitPArr ty []) = do
 371     emptyP <- dsLookupDPHId emptyPName
 372     return (Var emptyP `App` Type ty)
 373 dsExpr (ExplicitPArr ty xs) = do
 374     singletonP <- dsLookupDPHId singletonPName
 375     appP       <- dsLookupDPHId appPName
 376     xs'        <- mapM dsLExpr xs
 377     return . foldr1 (binary appP) $ map (unary singletonP) xs'
 378   where
 379     unary  fn x   = mkApps (Var fn) [Type ty, x]
 380     binary fn x y = mkApps (Var fn) [Type ty, x, y]
 381
 382 dsExpr (ArithSeq expr (From from))
 383   = App <$> dsExpr expr <*> dsLExpr from
 384
 385 dsExpr (ArithSeq expr (FromTo from to))
 386   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
 387
 388 dsExpr (ArithSeq expr (FromThen from thn))
 389   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
 390
 391 dsExpr (ArithSeq expr (FromThenTo from thn to))
 392   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
 393
 394 dsExpr (PArrSeq expr (FromTo from to))
 395   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
 396
 397 dsExpr (PArrSeq expr (FromThenTo from thn to))
 398   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
 399
 400 dsExpr (PArrSeq _ _)
 401   = panic "DsExpr.dsExpr: Infinite parallel array!"
 402     -- the parser shouldn't have generated it and the renamer and typechecker
 403     -- shouldn't have let it through
 404 \end{code}
 405
 406 \noindent
 407 \underline{\bf Record construction and update}
 408 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 409 For record construction we do this (assuming T has three arguments)
 410 \begin{verbatim}
 411         T { op2 = e }
 412 ==>
 413         let err = /\a -> recConErr a
 414         T (recConErr t1 "M.lhs/230/op1")
 415           e
 416           (recConErr t1 "M.lhs/230/op3")
 417 \end{verbatim}
 418 @recConErr@ then converts its arugment string into a proper message
 419 before printing it as
 420 \begin{verbatim}
 421         M.lhs, line 230: missing field op1 was evaluated
 422 \end{verbatim}
 423
 424 We also handle @C{}@ as valid construction syntax for an unlabelled
 425 constructor @C@, setting all of @C@'s fields to bottom.
 426
 427 \begin{code}
 428 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
 429     con_expr' <- dsExpr con_expr
 430     let
 431         (arg_tys, _) = tcSplitFunTys (exprType con_expr')
 432         -- A newtype in the corner should be opaque;
 433         -- hence TcType.tcSplitFunTys
 434
 435         mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
 436           = case findField (rec_flds rbinds) lbl of
 437               (rhs:rhss) -> ASSERT( null rhss )
 438                             dsLExpr rhs
 439               []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
 440         unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
 441
 442         labels = dataConFieldLabels (idDataCon data_con_id)
 443         -- The data_con_id is guaranteed to be the wrapper id of the constructor
 444
 445     con_args <- if null labels
 446                 then mapM unlabelled_bottom arg_tys
 447                 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
 448
 449     return (mkApps con_expr' con_args)
 450 \end{code}
 451
 452 Record update is a little harder. Suppose we have the decl:
 453 \begin{verbatim}
 454         data T = T1 {op1, op2, op3 :: Int}
 455                | T2 {op4, op2 :: Int}
 456                | T3
 457 \end{verbatim}
 458 Then we translate as follows:
 459 \begin{verbatim}
 460         r { op2 = e }
 461 ===>
 462         let op2 = e in
 463         case r of
 464           T1 op1 _ op3 -> T1 op1 op2 op3
 465           T2 op4 _     -> T2 op4 op2
 466           other        -> recUpdError "M.lhs/230"
 467 \end{verbatim}
 468 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
 469 RHSs, and do not generate a Core constructor application directly, because the constructor
 470 might do some argument-evaluation first; and may have to throw away some
 471 dictionaries.
 472
 473 Note [Update for GADTs]
 474 ~~~~~~~~~~~~~~~~~~~~~~~
 475 Consider
 476    data T a b where
 477      T1 { f1 :: a } :: T a Int
 478
 479 Then the wrapper function for T1 has type
 480    $WT1 :: a -> T a Int
 481 But if x::T a b, then
 482    x { f1 = v } :: T a b   (not T a Int!)
 483 So we need to cast (T a Int) to (T a b).  Sigh.
 484
 485 \begin{code}
 486 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
 487                        cons_to_upd in_inst_tys out_inst_tys)
 488   | null fields
 489   = dsLExpr record_expr
 490   | otherwise
 491   = ASSERT2( notNull cons_to_upd, ppr expr )
 492
 493     do  { record_expr' <- dsLExpr record_expr
 494         ; field_binds' <- mapM ds_field fields
 495         ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
 496               upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
 497
 498         -- It's important to generate the match with matchWrapper,
 499         -- and the right hand sides with applications of the wrapper Id
 500         -- so that everything works when we are doing fancy unboxing on the
 501         -- constructor aguments.
 502         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
 503         ; ([discrim_var], matching_code)
 504                 <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
 505
 506         ; return (add_field_binds field_binds' $
 507                   bindNonRec discrim_var record_expr' matching_code) }
 508   where
 509     ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
 510       -- Clone the Id in the HsRecField, because its Name is that
 511       -- of the record selector, and we must not make that a lcoal binder
 512       -- else we shadow other uses of the record selector
 513       -- Hence 'lcl_id'.  Cf Trac #2735
 514     ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
 515                             ; let fld_id = unLoc (hsRecFieldId rec_field)
 516                             ; lcl_id <- newSysLocalDs (idType fld_id)
 517                             ; return (idName fld_id, lcl_id, rhs) }
 518
 519     add_field_binds [] expr = expr
 520     add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
 521
 522         -- Awkwardly, for families, the match goes
 523         -- from instance type to family type
 524     tycon     = dataConTyCon (head cons_to_upd)
 525     in_ty     = mkTyConApp tycon in_inst_tys
 526     in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
 527
 528     mk_alt upd_fld_env con
 529       = do { let (univ_tvs, ex_tvs, eq_spec,
 530                   theta, arg_tys, _) = dataConFullSig con
 531                  subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
 532
 533                 -- I'm not bothering to clone the ex_tvs
 534            ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
 535            ; theta_vars <- mapM newPredVarDs (substTheta subst theta)
 536            ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
 537            ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
 538                                          (dataConFieldLabels con) arg_ids
 539                  mk_val_arg field_name pat_arg_id
 540                      = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
 541                  inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
 542                         -- Reconstruct with the WrapId so that unpacking happens
 543                  wrap = mkWpEvVarApps theta_vars          `WpCompose`
 544                         mkWpTyApps    (mkTyVarTys ex_tvs) `WpCompose`
 545                         mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
 546                                        , not (tv `elemVarEnv` wrap_subst) ]
 547                  rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
 548
 549                         -- Tediously wrap the application in a cast
 550                         -- Note [Update for GADTs]
 551                  wrapped_rhs | null eq_spec = rhs
 552                              | otherwise    = mkLHsWrap (WpCast wrap_co) rhs
 553                  wrap_co = mkTyConAppCo tycon [ lookup tv ty
 554                                               | (tv,ty) <- univ_tvs `zip` out_inst_tys]
 555                  lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of
 556                                         Just co' -> co'
 557                                         Nothing  -> mkReflCo ty
 558                  wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var))
 559                                        | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
 560
 561                  pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
 562                                          , pat_dicts = eqs_vars ++ theta_vars
 563                                          , pat_binds = emptyTcEvBinds
 564                                          , pat_args = PrefixCon $ map nlVarPat arg_ids
 565                                          , pat_ty = in_ty }
 566            ; return (mkSimpleMatch [pat] wrapped_rhs) }
 567
 568 \end{code}
 569
 570 Here is where we desugar the Template Haskell brackets and escapes
 571
 572 \begin{code}
 573 -- Template Haskell stuff
 574
 575 #ifdef GHCI     /* Only if bootstrapping */
 576 dsExpr (HsBracketOut x ps) = dsBracket x ps
 577 dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
 578 #endif
 579
 580 -- Arrow notation extension
 581 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
 582 \end{code}
 583
 584 Hpc Support
 585
 586 \begin{code}
 587 dsExpr (HsTick ix vars e) = do
 588   e' <- dsLExpr e
 589   mkTickBox ix vars e'
 590
 591 -- There is a problem here. The then and else branches
 592 -- have no free variables, so they are open to lifting.
 593 -- We need someway of stopping this.
 594 -- This will make no difference to binary coverage
 595 -- (did you go here: YES or NO), but will effect accurate
 596 -- tick counting.
 597
 598 dsExpr (HsBinTick ixT ixF e) = do
 599   e2 <- dsLExpr e
 600   do { ASSERT(exprType e2 `eqType` boolTy)
 601        mkBinaryTickBox ixT ixF e2
 602      }
 603 \end{code}
 604
 605 \begin{code}
 606
 607 -- HsSyn constructs that just shouldn't be here:
 608 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
 609
 610
 611 findField :: [HsRecField Id arg] -> Name -> [arg]
 612 findField rbinds lbl
 613   = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
 614          , lbl == idName (unLoc id) ]
 615 \end{code}
 616
 617 %--------------------------------------------------------------------
 618
 619 Note [Desugaring explicit lists]
 620 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 621 Explicit lists are desugared in a cleverer way to prevent some
 622 fruitless allocations.  Essentially, whenever we see a list literal
 623 [x_1, ..., x_n] we:
 624
 625 1. Find the tail of the list that can be allocated statically (say
 626    [x_k, ..., x_n]) by later stages and ensure we desugar that
 627    normally: this makes sure that we don't cause a code size increase
 628    by having the cons in that expression fused (see later) and hence
 629    being unable to statically allocate any more
 630
 631 2. For the prefix of the list which cannot be allocated statically,
 632    say [x_1, ..., x_(k-1)], we turn it into an expression involving
 633    build so that if we find any foldrs over it it will fuse away
 634    entirely!
 635
 636    So in this example we will desugar to:
 637    build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
 638
 639    If fusion fails to occur then build will get inlined and (since we
 640    defined a RULE for foldr (:) []) we will get back exactly the
 641    normal desugaring for an explicit list.
 642
 643 This optimisation can be worth a lot: up to 25% of the total
 644 allocation in some nofib programs. Specifically
 645
 646         Program           Size    Allocs   Runtime  CompTime
 647         rewrite          +0.0%    -26.3%      0.02     -1.8%
 648            ansi          -0.3%    -13.8%      0.00     +0.0%
 649            lift          +0.0%     -8.7%      0.00     -2.3%
 650
 651 Of course, if rules aren't turned on then there is pretty much no
 652 point doing this fancy stuff, and it may even be harmful.
 653
 654 =======>  Note by SLPJ Dec 08.
 655
 656 I'm unconvinced that we should *ever* generate a build for an explicit
 657 list.  See the comments in GHC.Base about the foldr/cons rule, which
 658 points out that (foldr k z [a,b,c]) may generate *much* less code than
 659 (a `k` b `k` c `k` z).
 660
 661 Furthermore generating builds messes up the LHS of RULES.
 662 Example: the foldr/single rule in GHC.Base
 663    foldr k z [x] = ...
 664 We do not want to generate a build invocation on the LHS of this RULE!
 665
 666 We fix this by disabling rules in rule LHSs, and testing that
 667 flag here; see Note [Desugaring RULE left hand sides] in Desugar
 668
 669 To test this I've added a (static) flag -fsimple-list-literals, which
 670 makes all list literals be generated via the simple route.
 671
 672
 673 \begin{code}
 674 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
 675 -- See Note [Desugaring explicit lists]
 676 dsExplicitList elt_ty xs
 677   = do { dflags <- getDOptsDs
 678        ; xs' <- mapM dsLExpr xs
 679        ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
 680        ; if opt_SimpleListLiterals                      -- -fsimple-list-literals
 681          || not (dopt Opt_EnableRewriteRules dflags)    -- Rewrite rules off
 682                 -- Don't generate a build if there are no rules to eliminate it!
 683                 -- See Note [Desugaring RULE left hand sides] in Desugar
 684          || null dynamic_prefix   -- Avoid build (\c n. foldr c n xs)!
 685          then return $ mkListExpr elt_ty xs'
 686          else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
 687   where
 688     is_static :: CoreExpr -> Bool
 689     is_static e = all is_static_var (varSetElems (exprFreeVars e))
 690
 691     is_static_var :: Var -> Bool
 692     is_static_var v
 693       | isId v = isExternalName (idName v)  -- Top-level things are given external names
 694       | otherwise = False                   -- Type variables
 695
 696     mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
 697       = do { let suffix' = mkListExpr elt_ty suffix
 698            ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
 699            ; return (foldr (App . App (Var c)) folded_suffix prefix) }
 700
 701 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
 702 spanTail f xs = (reverse rejected, reverse satisfying)
 703     where (satisfying, rejected) = span f $ reverse xs
 704 \end{code}
 705
 706 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
 707 handled in DsListComp).  Basically does the translation given in the
 708 Haskell 98 report:
 709
 710 \begin{code}
 711 dsDo    :: [LStmt Id]
 712         -> LHsExpr Id
 713         -> Type                 -- Type of the whole expression
 714         -> DsM CoreExpr
 715
 716 dsDo stmts body result_ty
 717   = goL stmts
 718   where
 719     -- result_ty must be of the form (m b)
 720     (m_ty, _b_ty) = tcSplitAppTy result_ty
 721
 722     goL [] = dsLExpr body
 723     goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
 724
 725     go _ (ExprStmt rhs then_expr _) stmts
 726       = do { rhs2 <- dsLExpr rhs
 727            ; case tcSplitAppTy_maybe (exprType rhs2) of
 728                 Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
 729                 _                                 -> return ()
 730            ; then_expr2 <- dsExpr then_expr
 731            ; rest <- goL stmts
 732            ; return (mkApps then_expr2 [rhs2, rest]) }
 733
 734     go _ (LetStmt binds) stmts
 735       = do { rest <- goL stmts
 736            ; dsLocalBinds binds rest }
 737
 738     go _ (BindStmt pat rhs bind_op fail_op) stmts
 739       = do  { body     <- goL stmts
 740             ; rhs'     <- dsLExpr rhs
 741             ; bind_op' <- dsExpr bind_op
 742             ; var   <- selectSimpleMatchVarL pat
 743             ; let bind_ty = exprType bind_op'   -- rhs -> (pat -> res1) -> res2
 744                   res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
 745             ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
 746                                       res1_ty (cantFailMatchResult body)
 747             ; match_code <- handle_failure pat match fail_op
 748             ; return (mkApps bind_op' [rhs', Lam var match_code]) }
 749
 750     go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
 751                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op
 752                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
 753                     , recS_rec_rets = rec_rets }) stmts
 754       = ASSERT( length rec_ids > 0 )
 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 handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
 778     -- In a do expression, pattern-match failure just calls
 779     -- the monadic 'fail' rather than throwing an exception
 780 handle_failure pat match fail_op
 781   | matchCanFail match
 782   = do { fail_op' <- dsExpr fail_op
 783        ; fail_msg <- mkStringExpr (mk_fail_msg pat)
 784        ; extractMatchResult match (App fail_op' fail_msg) }
 785   | otherwise
 786   = extractMatchResult match (error "It can't fail")
 787
 788 mk_fail_msg :: Located e -> String
 789 mk_fail_msg pat = "Pattern match failure in do expression at " ++
 790                   showSDoc (ppr (getLoc pat))
 791 \end{code}
 792
 793 Translation for RecStmt's:
 794 -----------------------------
 795 We turn (RecStmt [v1,..vn] stmts) into:
 796
 797   (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
 798                                       return (v1,..vn))
 799
 800 \begin{code}
 801 {-
 802 dsMDo   :: HsStmtContext Name
 803         -> [(Name,Id)]
 804         -> [LStmt Id]
 805         -> LHsExpr Id
 806         -> Type                 -- Type of the whole expression
 807         -> DsM CoreExpr
 808
 809 dsMDo ctxt tbl stmts body result_ty
 810   = goL stmts
 811   where
 812     goL [] = dsLExpr body
 813     goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
 814
 815     (m_ty, b_ty) = tcSplitAppTy result_ty       -- result_ty must be of the form (m b)
 816     return_id = lookupEvidence tbl returnMName
 817     bind_id   = lookupEvidence tbl bindMName
 818     then_id   = lookupEvidence tbl thenMName
 819     fail_id   = lookupEvidence tbl failMName
 820
 821     go _ (LetStmt binds) stmts
 822       = do { rest <- goL stmts
 823            ; dsLocalBinds binds rest }
 824
 825     go _ (ExprStmt rhs then_expr rhs_ty) stmts
 826       = do { rhs2 <- dsLExpr rhs
 827            ; warnDiscardedDoBindings rhs m_ty rhs_ty
 828            ; then_expr2 <- dsExpr then_expr
 829            ; rest <- goL stmts
 830            ; return (mkApps then_expr2 [rhs2, rest]) }
 831
 832     go _ (BindStmt pat rhs bind_op _) stmts
 833       = do { body     <- goL stmts
 834            ; rhs'     <- dsLExpr rhs
 835            ; bind_op' <- dsExpr bind_op
 836            ; var   <- selectSimpleMatchVarL pat
 837            ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
 838                                      result_ty (cantFailMatchResult body)
 839            ; match_code <- handle_failure pat match fail_op
 840            ; return (mkApps bind_op [rhs', Lam var match_code]) }
 841
 842     go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
 843                     , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
 844                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts
 845       = ASSERT( length rec_ids > 0 )
 846         ASSERT( length rec_ids == length rec_rets )
 847         ASSERT( isEmptyTcEvBinds _ev_binds )
 848         pprTrace "dsMDo" (ppr later_ids) $
 849          goL (new_bind_stmt : stmts)
 850       where
 851         new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app
 852                                          bind_op noSyntaxExpr
 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 (noLoc mfix_op) 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 (noLoc return_op) (mkLHsTupleExpr rets)
 877
 878         mk_wild_pat :: Id -> LPat Id
 879         mk_wild_pat v = noLoc $ WildPat $ idType v
 880
 881         mk_later_pat :: Id -> LPat Id
 882         mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
 883                        | otherwise           = nlVarPat v
 884
 885         mk_tup_pat :: [LPat Id] -> LPat Id
 886         mk_tup_pat [p] = p
 887         mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
 888 -}
 889 \end{code}
 890
 891
 892 %************************************************************************
 893 %*                                                                      *
 894                  Warning about identities
 895 %*                                                                      *
 896 %************************************************************************
 897
 898 Warn about functions that convert between one type and another
 899 when the to- and from- types are the same.  Then it's probably
 900 (albeit not definitely) the identity
 901 \begin{code}
 902 warnAboutIdentities :: CoreExpr -> (CoreExpr -> CoreExpr) -> DsM ()
 903 warnAboutIdentities (Var v) co_fn
 904   | idName v `elem` conversionNames
 905   , let fun_ty = exprType (co_fn (Var v))
 906   , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
 907   , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
 908   = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
 909                  , nest 2 $ ptext (sLit "can probably be omitted")
 910                  , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)"))
 911            ])
 912 warnAboutIdentities _ _ = return ()
 913
 914 conversionNames :: [Name]
 915 conversionNames
 916   = [ toIntegerName, toRationalName
 917     , fromIntegralName, realToFracName ]
 918  -- We can't easily add fromIntegerName, fromRationalName,
 919  -- becuase they are generated by literals
 920 \end{code}
 921
 922 %************************************************************************
 923 %*                                                                      *
 924 \subsection{Errors and contexts}
 925 %*                                                                      *
 926 %************************************************************************
 927
 928 \begin{code}
 929 -- Warn about certain types of values discarded in monadic bindings (#3263)
 930 warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
 931 warnDiscardedDoBindings rhs container_ty returning_ty = do {
 932           -- Warn about discarding non-() things in 'monadic' binding
 933         ; warn_unused <- doptDs Opt_WarnUnusedDoBind
 934         ; if warn_unused && not (returning_ty `eqType` unitTy)
 935            then warnDs (unusedMonadBind rhs returning_ty)
 936            else do {
 937           -- Warn about discarding m a things in 'monadic' binding of the same type,
 938           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
 939         ; warn_wrong <- doptDs Opt_WarnWrongDoBind
 940         ; case tcSplitAppTy_maybe returning_ty of
 941                   Just (returning_container_ty, _) -> when (warn_wrong && container_ty `eqType` returning_container_ty) $
 942                                                             warnDs (wrongMonadBind rhs returning_ty)
 943                   _ -> return () } }
 944
 945 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
 946 unusedMonadBind rhs returning_ty
 947   = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
 948     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
 949     ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
 950
 951 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
 952 wrongMonadBind rhs returning_ty
 953   = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
 954     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
 955     ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
 956 \end{code}