compiler/deSugar/DsExpr.lhs

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