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