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