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