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