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