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 We fix this by disabling rules in rule LHSs, and testing that
 647 flag here; see Note [Desugaring RULE left hand sides] in Desugar
 648
 649 To test this I've added a (static) flag -fsimple-list-literals, which
 650 makes all list literals be generated via the simple route.
 651
 652
 653 \begin{code}
 654 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
 655 -- See Note [Desugaring explicit lists]
 656 dsExplicitList elt_ty xs
 657   = do { dflags <- getDOptsDs
 658        ; xs' <- mapM dsLExpr xs
 659        ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
 660        ; if opt_SimpleListLiterals                      -- -fsimple-list-literals
 661          || not (dopt Opt_EnableRewriteRules dflags)    -- Rewrite rules off
 662                 -- Don't generate a build if there are no rules to eliminate it!
 663                 -- See Note [Desugaring RULE left hand sides] in Desugar
 664          || null dynamic_prefix   -- Avoid build (\c n. foldr c n xs)!
 665          then return $ mkListExpr elt_ty xs'
 666          else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
 667   where
 668     is_static :: CoreExpr -> Bool
 669     is_static e = all is_static_var (varSetElems (exprFreeVars e))
 670
 671     is_static_var :: Var -> Bool
 672     is_static_var v
 673       | isId v = isExternalName (idName v)  -- Top-level things are given external names
 674       | otherwise = False                   -- Type variables
 675
 676     mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
 677       = do { let suffix' = mkListExpr elt_ty suffix
 678            ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
 679            ; return (foldr (App . App (Var c)) folded_suffix prefix) }
 680
 681 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
 682 spanTail f xs = (reverse rejected, reverse satisfying)
 683     where (satisfying, rejected) = span f $ reverse xs
 684 \end{code}
 685
 686 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
 687 handled in DsListComp).  Basically does the translation given in the
 688 Haskell 98 report:
 689
 690 \begin{code}
 691 dsDo    :: [LStmt Id]
 692         -> LHsExpr Id
 693         -> Type                 -- Type of the whole expression
 694         -> DsM CoreExpr
 695
 696 dsDo stmts body result_ty
 697   = goL stmts
 698   where
 699     -- result_ty must be of the form (m b)
 700     (m_ty, _b_ty) = tcSplitAppTy result_ty
 701
 702     goL [] = dsLExpr body
 703     goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
 704
 705     go _ (ExprStmt rhs then_expr _) stmts
 706       = do { rhs2 <- dsLExpr rhs
 707            ; case tcSplitAppTy_maybe (exprType rhs2) of
 708                 Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
 709                 _                                 -> return ()
 710            ; then_expr2 <- dsExpr then_expr
 711            ; rest <- goL stmts
 712            ; return (mkApps then_expr2 [rhs2, rest]) }
 713
 714     go _ (LetStmt binds) stmts
 715       = do { rest <- goL stmts
 716            ; dsLocalBinds binds rest }
 717
 718     go _ (BindStmt pat rhs bind_op fail_op) stmts
 719       = do  { body     <- goL stmts
 720             ; rhs'     <- dsLExpr rhs
 721             ; bind_op' <- dsExpr bind_op
 722             ; var   <- selectSimpleMatchVarL pat
 723             ; let bind_ty = exprType bind_op'   -- rhs -> (pat -> res1) -> res2
 724                   res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
 725             ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
 726                                       res1_ty (cantFailMatchResult body)
 727             ; match_code <- handle_failure pat match fail_op
 728             ; return (mkApps bind_op' [rhs', Lam var match_code]) }
 729
 730     go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
 731                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op
 732                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
 733                     , recS_rec_rets = rec_rets, recS_dicts = binds }) stmts
 734       = ASSERT( length rec_ids > 0 )
 735         goL (new_bind_stmt : let_stmt : stmts)
 736       where
 737         -- returnE <- dsExpr return_id
 738         -- mfixE <- dsExpr mfix_id
 739         new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
 740                                          bind_op
 741                                              noSyntaxExpr  -- Tuple cannot fail
 742
 743         let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
 744
 745         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
 746         rec_tup_pats = map nlVarPat tup_ids
 747         later_pats   = rec_tup_pats
 748         rets         = map noLoc rec_rets
 749
 750         mfix_app   = nlHsApp (noLoc mfix_op) mfix_arg
 751         mfix_arg   = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
 752                                              (mkFunTy tup_ty body_ty))
 753         mfix_pat   = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
 754         body       = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
 755         return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
 756         body_ty    = mkAppTy m_ty tup_ty
 757         tup_ty     = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
 758
 759     -- In a do expression, pattern-match failure just calls
 760     -- the monadic 'fail' rather than throwing an exception
 761     handle_failure pat match fail_op
 762       | matchCanFail match
 763       = do { fail_op' <- dsExpr fail_op
 764            ; fail_msg <- mkStringExpr (mk_fail_msg pat)
 765            ; extractMatchResult match (App fail_op' fail_msg) }
 766       | otherwise
 767       = extractMatchResult match (error "It can't fail")
 768
 769 mk_fail_msg :: Located e -> String
 770 mk_fail_msg pat = "Pattern match failure in do expression at " ++
 771                   showSDoc (ppr (getLoc pat))
 772 \end{code}
 773
 774 Translation for RecStmt's:
 775 -----------------------------
 776 We turn (RecStmt [v1,..vn] stmts) into:
 777
 778   (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
 779                                       return (v1,..vn))
 780
 781 \begin{code}
 782 dsMDo   :: PostTcTable
 783         -> [LStmt Id]
 784         -> LHsExpr Id
 785         -> Type                 -- Type of the whole expression
 786         -> DsM CoreExpr
 787
 788 dsMDo tbl stmts body result_ty
 789   = goL stmts
 790   where
 791     goL [] = dsLExpr body
 792     goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
 793
 794     (m_ty, b_ty) = tcSplitAppTy result_ty       -- result_ty must be of the form (m b)
 795     mfix_id   = lookupEvidence tbl mfixName
 796     return_id = lookupEvidence tbl returnMName
 797     bind_id   = lookupEvidence tbl bindMName
 798     then_id   = lookupEvidence tbl thenMName
 799     fail_id   = lookupEvidence tbl failMName
 800     ctxt      = MDoExpr tbl
 801
 802     go _ (LetStmt binds) stmts
 803       = do { rest <- goL stmts
 804            ; dsLocalBinds binds rest }
 805
 806     go _ (ExprStmt rhs _ rhs_ty) stmts
 807       = do { rhs2 <- dsLExpr rhs
 808            ; warnDiscardedDoBindings rhs m_ty rhs_ty
 809            ; rest <- goL stmts
 810            ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
 811
 812     go _ (BindStmt pat rhs _ _) stmts
 813       = do { body  <- goL stmts
 814            ; var   <- selectSimpleMatchVarL pat
 815            ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
 816                                   result_ty (cantFailMatchResult body)
 817            ; fail_msg   <- mkStringExpr (mk_fail_msg pat)
 818            ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
 819            ; match_code <- extractMatchResult match fail_expr
 820
 821            ; rhs'       <- dsLExpr rhs
 822            ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
 823                                              rhs', Lam var match_code]) }
 824
 825     go loc (RecStmt rec_stmts later_ids rec_ids _ _ _ rec_rets binds) stmts
 826       = ASSERT( length rec_ids > 0 )
 827         ASSERT( length rec_ids == length rec_rets )
 828         pprTrace "dsMDo" (ppr later_ids) $
 829          goL (new_bind_stmt : let_stmt : stmts)
 830       where
 831         new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
 832         let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
 833
 834
 835                 -- Remove the later_ids that appear (without fancy coercions)
 836                 -- in rec_rets, because there's no need to knot-tie them separately
 837                 -- See Note [RecStmt] in HsExpr
 838         later_ids'   = filter (`notElem` mono_rec_ids) later_ids
 839         mono_rec_ids = [ id | HsVar id <- rec_rets ]
 840
 841         mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
 842         mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
 843                                              (mkFunTy tup_ty body_ty))
 844
 845         -- The rec_tup_pat must bind the rec_ids only; remember that the
 846         --      trimmed_laters may share the same Names
 847         -- Meanwhile, the later_pats must bind the later_vars
 848         rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
 849         later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
 850         rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
 851
 852         mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
 853         body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
 854         body_ty = mkAppTy m_ty tup_ty
 855         tup_ty  = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids))  -- Deals with singleton case
 856
 857         return_app  = nlHsApp (nlHsTyApp return_id [tup_ty])
 858                               (mkLHsTupleExpr rets)
 859
 860         mk_wild_pat :: Id -> LPat Id
 861         mk_wild_pat v = noLoc $ WildPat $ idType v
 862
 863         mk_later_pat :: Id -> LPat Id
 864         mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
 865                        | otherwise           = nlVarPat v
 866
 867         mk_tup_pat :: [LPat Id] -> LPat Id
 868         mk_tup_pat [p] = p
 869         mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
 870 \end{code}
 871
 872
 873 %************************************************************************
 874 %*                                                                      *
 875 \subsection{Errors and contexts}
 876 %*                                                                      *
 877 %************************************************************************
 878
 879 \begin{code}
 880 -- Warn about certain types of values discarded in monadic bindings (#3263)
 881 warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
 882 warnDiscardedDoBindings rhs container_ty returning_ty = do {
 883           -- Warn about discarding non-() things in 'monadic' binding
 884         ; warn_unused <- doptDs Opt_WarnUnusedDoBind
 885         ; if warn_unused && not (returning_ty `tcEqType` unitTy)
 886            then warnDs (unusedMonadBind rhs returning_ty)
 887            else do {
 888           -- Warn about discarding m a things in 'monadic' binding of the same type,
 889           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
 890         ; warn_wrong <- doptDs Opt_WarnWrongDoBind
 891         ; case tcSplitAppTy_maybe returning_ty of
 892                   Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
 893                                                             warnDs (wrongMonadBind rhs returning_ty)
 894                   _ -> return () } }
 895
 896 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
 897 unusedMonadBind rhs returning_ty
 898   = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
 899     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
 900     ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
 901
 902 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
 903 wrongMonadBind rhs returning_ty
 904   = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
 905     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
 906     ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
 907 \end{code}