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 GhciStmt stmts body result_ty)
 327   = dsDo stmts body result_ty
 328
 329 dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
 330   = dsMDo tbl stmts body result_ty
 331
 332 dsExpr (HsDo PArrComp stmts body result_ty)
 333   =     -- Special case for array comprehensions
 334     dsPArrComp (map unLoc stmts) body elt_ty
 335   where
 336     [elt_ty] = tcTyConAppArgs result_ty
 337
 338 dsExpr (HsIf guard_expr then_expr else_expr)
 339   = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
 340 \end{code}
 341
 342
 343 \noindent
 344 \underline{\bf Various data construction things}
 345 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 346 \begin{code}
 347 dsExpr (ExplicitList elt_ty xs)
 348   = dsExplicitList elt_ty xs
 349
 350 -- We desugar [:x1, ..., xn:] as
 351 --   singletonP x1 +:+ ... +:+ singletonP xn
 352 --
 353 dsExpr (ExplicitPArr ty []) = do
 354     emptyP <- dsLookupGlobalId emptyPName
 355     return (Var emptyP `App` Type ty)
 356 dsExpr (ExplicitPArr ty xs) = do
 357     singletonP <- dsLookupGlobalId singletonPName
 358     appP       <- dsLookupGlobalId appPName
 359     xs'        <- mapM dsLExpr xs
 360     return . foldr1 (binary appP) $ map (unary singletonP) xs'
 361   where
 362     unary  fn x   = mkApps (Var fn) [Type ty, x]
 363     binary fn x y = mkApps (Var fn) [Type ty, x, y]
 364
 365 dsExpr (ArithSeq expr (From from))
 366   = App <$> dsExpr expr <*> dsLExpr from
 367
 368 dsExpr (ArithSeq expr (FromTo from to))
 369   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
 370
 371 dsExpr (ArithSeq expr (FromThen from thn))
 372   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
 373
 374 dsExpr (ArithSeq expr (FromThenTo from thn to))
 375   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
 376
 377 dsExpr (PArrSeq expr (FromTo from to))
 378   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
 379
 380 dsExpr (PArrSeq expr (FromThenTo from thn to))
 381   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
 382
 383 dsExpr (PArrSeq _ _)
 384   = panic "DsExpr.dsExpr: Infinite parallel array!"
 385     -- the parser shouldn't have generated it and the renamer and typechecker
 386     -- shouldn't have let it through
 387 \end{code}
 388
 389 \noindent
 390 \underline{\bf Record construction and update}
 391 %              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 392 For record construction we do this (assuming T has three arguments)
 393 \begin{verbatim}
 394         T { op2 = e }
 395 ==>
 396         let err = /\a -> recConErr a
 397         T (recConErr t1 "M.lhs/230/op1")
 398           e
 399           (recConErr t1 "M.lhs/230/op3")
 400 \end{verbatim}
 401 @recConErr@ then converts its arugment string into a proper message
 402 before printing it as
 403 \begin{verbatim}
 404         M.lhs, line 230: missing field op1 was evaluated
 405 \end{verbatim}
 406
 407 We also handle @C{}@ as valid construction syntax for an unlabelled
 408 constructor @C@, setting all of @C@'s fields to bottom.
 409
 410 \begin{code}
 411 dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
 412     con_expr' <- dsExpr con_expr
 413     let
 414         (arg_tys, _) = tcSplitFunTys (exprType con_expr')
 415         -- A newtype in the corner should be opaque;
 416         -- hence TcType.tcSplitFunTys
 417
 418         mk_arg (arg_ty, lbl)    -- Selector id has the field label as its name
 419           = case findField (rec_flds rbinds) lbl of
 420               (rhs:rhss) -> ASSERT( null rhss )
 421                             dsLExpr rhs
 422               []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
 423         unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
 424
 425         labels = dataConFieldLabels (idDataCon data_con_id)
 426         -- The data_con_id is guaranteed to be the wrapper id of the constructor
 427
 428     con_args <- if null labels
 429                 then mapM unlabelled_bottom arg_tys
 430                 else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
 431
 432     return (mkApps con_expr' con_args)
 433 \end{code}
 434
 435 Record update is a little harder. Suppose we have the decl:
 436 \begin{verbatim}
 437         data T = T1 {op1, op2, op3 :: Int}
 438                | T2 {op4, op2 :: Int}
 439                | T3
 440 \end{verbatim}
 441 Then we translate as follows:
 442 \begin{verbatim}
 443         r { op2 = e }
 444 ===>
 445         let op2 = e in
 446         case r of
 447           T1 op1 _ op3 -> T1 op1 op2 op3
 448           T2 op4 _     -> T2 op4 op2
 449           other        -> recUpdError "M.lhs/230"
 450 \end{verbatim}
 451 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
 452 RHSs, and do not generate a Core constructor application directly, because the constructor
 453 might do some argument-evaluation first; and may have to throw away some
 454 dictionaries.
 455
 456 Note [Update for GADTs]
 457 ~~~~~~~~~~~~~~~~~~~~~~~
 458 Consider
 459    data T a b where
 460      T1 { f1 :: a } :: T a Int
 461
 462 Then the wrapper function for T1 has type
 463    $WT1 :: a -> T a Int
 464 But if x::T a b, then
 465    x { f1 = v } :: T a b   (not T a Int!)
 466 So we need to cast (T a Int) to (T a b).  Sigh.
 467
 468 \begin{code}
 469 dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
 470                        cons_to_upd in_inst_tys out_inst_tys)
 471   | null fields
 472   = dsLExpr record_expr
 473   | otherwise
 474   = ASSERT2( notNull cons_to_upd, ppr expr )
 475
 476     do  { record_expr' <- dsLExpr record_expr
 477         ; field_binds' <- mapM ds_field fields
 478         ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
 479               upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
 480
 481         -- It's important to generate the match with matchWrapper,
 482         -- and the right hand sides with applications of the wrapper Id
 483         -- so that everything works when we are doing fancy unboxing on the
 484         -- constructor aguments.
 485         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
 486         ; ([discrim_var], matching_code)
 487                 <- matchWrapper RecUpd (MatchGroup alts in_out_ty)
 488
 489         ; return (add_field_binds field_binds' $
 490                   bindNonRec discrim_var record_expr' matching_code) }
 491   where
 492     ds_field :: HsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)
 493       -- Clone the Id in the HsRecField, because its Name is that
 494       -- of the record selector, and we must not make that a lcoal binder
 495       -- else we shadow other uses of the record selector
 496       -- Hence 'lcl_id'.  Cf Trac #2735
 497     ds_field rec_field = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
 498                             ; let fld_id = unLoc (hsRecFieldId rec_field)
 499                             ; lcl_id <- newSysLocalDs (idType fld_id)
 500                             ; return (idName fld_id, lcl_id, rhs) }
 501
 502     add_field_binds [] expr = expr
 503     add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
 504
 505         -- Awkwardly, for families, the match goes
 506         -- from instance type to family type
 507     tycon     = dataConTyCon (head cons_to_upd)
 508     in_ty     = mkTyConApp tycon in_inst_tys
 509     in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
 510
 511     mk_alt upd_fld_env con
 512       = do { let (univ_tvs, ex_tvs, eq_spec,
 513                   eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
 514                  subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
 515
 516                 -- I'm not bothering to clone the ex_tvs
 517            ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
 518            ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
 519            ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
 520            ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
 521                                          (dataConFieldLabels con) arg_ids
 522                  mk_val_arg field_name pat_arg_id
 523                      = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
 524                  inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
 525                         -- Reconstruct with the WrapId so that unpacking happens
 526                  wrap = mkWpApps theta_vars `WpCompose`
 527                         mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
 528                         mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
 529                                        , isNothing (lookupTyVar wrap_subst tv) ]
 530                  rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
 531
 532                         -- Tediously wrap the application in a cast
 533                         -- Note [Update for GADTs]
 534                  wrapped_rhs | null eq_spec = rhs
 535                              | otherwise    = mkLHsWrap (WpCast wrap_co) rhs
 536                  wrap_co = mkTyConApp tycon [ lookup tv ty
 537                                             | (tv,ty) <- univ_tvs `zip` out_inst_tys]
 538                  lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
 539                                         Just ty' -> ty'
 540                                         Nothing  -> ty
 541                  wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
 542                                            | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
 543
 544                  pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
 545                                          , pat_dicts = eqs_vars ++ theta_vars
 546                                          , pat_binds = emptyLHsBinds
 547                                          , pat_args = PrefixCon $ map nlVarPat arg_ids
 548                                          , pat_ty = in_ty }
 549            ; return (mkSimpleMatch [pat] wrapped_rhs) }
 550
 551 \end{code}
 552
 553 Here is where we desugar the Template Haskell brackets and escapes
 554
 555 \begin{code}
 556 -- Template Haskell stuff
 557
 558 #ifdef GHCI     /* Only if bootstrapping */
 559 dsExpr (HsBracketOut x ps) = dsBracket x ps
 560 dsExpr (HsSpliceE s)       = pprPanic "dsExpr:splice" (ppr s)
 561 #endif
 562
 563 -- Arrow notation extension
 564 dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
 565 \end{code}
 566
 567 Hpc Support
 568
 569 \begin{code}
 570 dsExpr (HsTick ix vars e) = do
 571   e' <- dsLExpr e
 572   mkTickBox ix vars e'
 573
 574 -- There is a problem here. The then and else branches
 575 -- have no free variables, so they are open to lifting.
 576 -- We need someway of stopping this.
 577 -- This will make no difference to binary coverage
 578 -- (did you go here: YES or NO), but will effect accurate
 579 -- tick counting.
 580
 581 dsExpr (HsBinTick ixT ixF e) = do
 582   e2 <- dsLExpr e
 583   do { ASSERT(exprType e2 `coreEqType` boolTy)
 584        mkBinaryTickBox ixT ixF e2
 585      }
 586 \end{code}
 587
 588 \begin{code}
 589
 590 -- HsSyn constructs that just shouldn't be here:
 591 dsExpr (ExprWithTySig _ _)  = panic "dsExpr:ExprWithTySig"
 592
 593
 594 findField :: [HsRecField Id arg] -> Name -> [arg]
 595 findField rbinds lbl
 596   = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
 597          , lbl == idName (unLoc id) ]
 598 \end{code}
 599
 600 %--------------------------------------------------------------------
 601
 602 Note [Desugaring explicit lists]
 603 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 604 Explicit lists are desugared in a cleverer way to prevent some
 605 fruitless allocations.  Essentially, whenever we see a list literal
 606 [x_1, ..., x_n] we:
 607
 608 1. Find the tail of the list that can be allocated statically (say
 609    [x_k, ..., x_n]) by later stages and ensure we desugar that
 610    normally: this makes sure that we don't cause a code size increase
 611    by having the cons in that expression fused (see later) and hence
 612    being unable to statically allocate any more
 613
 614 2. For the prefix of the list which cannot be allocated statically,
 615    say [x_1, ..., x_(k-1)], we turn it into an expression involving
 616    build so that if we find any foldrs over it it will fuse away
 617    entirely!
 618
 619    So in this example we will desugar to:
 620    build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]
 621
 622    If fusion fails to occur then build will get inlined and (since we
 623    defined a RULE for foldr (:) []) we will get back exactly the
 624    normal desugaring for an explicit list.
 625
 626 This optimisation can be worth a lot: up to 25% of the total
 627 allocation in some nofib programs. Specifically
 628
 629         Program           Size    Allocs   Runtime  CompTime
 630         rewrite          +0.0%    -26.3%      0.02     -1.8%
 631            ansi          -0.3%    -13.8%      0.00     +0.0%
 632            lift          +0.0%     -8.7%      0.00     -2.3%
 633
 634 Of course, if rules aren't turned on then there is pretty much no
 635 point doing this fancy stuff, and it may even be harmful.
 636
 637 =======>  Note by SLPJ Dec 08.
 638
 639 I'm unconvinced that we should *ever* generate a build for an explicit
 640 list.  See the comments in GHC.Base about the foldr/cons rule, which
 641 points out that (foldr k z [a,b,c]) may generate *much* less code than
 642 (a `k` b `k` c `k` z).
 643
 644 Furthermore generating builds messes up the LHS of RULES.
 645 Example: the foldr/single rule in GHC.Base
 646    foldr k z [x] = ...
 647 We do not want to generate a build invocation on the LHS of this RULE!
 648
 649 We fix this by disabling rules in rule LHSs, and testing that
 650 flag here; see Note [Desugaring RULE left hand sides] in Desugar
 651
 652 To test this I've added a (static) flag -fsimple-list-literals, which
 653 makes all list literals be generated via the simple route.
 654
 655
 656 \begin{code}
 657 dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
 658 -- See Note [Desugaring explicit lists]
 659 dsExplicitList elt_ty xs
 660   = do { dflags <- getDOptsDs
 661        ; xs' <- mapM dsLExpr xs
 662        ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
 663        ; if opt_SimpleListLiterals                      -- -fsimple-list-literals
 664          || not (dopt Opt_EnableRewriteRules dflags)    -- Rewrite rules off
 665                 -- Don't generate a build if there are no rules to eliminate it!
 666                 -- See Note [Desugaring RULE left hand sides] in Desugar
 667          || null dynamic_prefix   -- Avoid build (\c n. foldr c n xs)!
 668          then return $ mkListExpr elt_ty xs'
 669          else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }
 670   where
 671     is_static :: CoreExpr -> Bool
 672     is_static e = all is_static_var (varSetElems (exprFreeVars e))
 673
 674     is_static_var :: Var -> Bool
 675     is_static_var v
 676       | isId v = isExternalName (idName v)  -- Top-level things are given external names
 677       | otherwise = False                   -- Type variables
 678
 679     mkSplitExplicitList prefix suffix (c, _) (n, n_ty)
 680       = do { let suffix' = mkListExpr elt_ty suffix
 681            ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
 682            ; return (foldr (App . App (Var c)) folded_suffix prefix) }
 683
 684 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
 685 spanTail f xs = (reverse rejected, reverse satisfying)
 686     where (satisfying, rejected) = span f $ reverse xs
 687 \end{code}
 688
 689 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
 690 handled in DsListComp).  Basically does the translation given in the
 691 Haskell 98 report:
 692
 693 \begin{code}
 694 dsDo    :: [LStmt Id]
 695         -> LHsExpr Id
 696         -> Type                 -- Type of the whole expression
 697         -> DsM CoreExpr
 698
 699 dsDo stmts body result_ty
 700   = goL stmts
 701   where
 702     -- result_ty must be of the form (m b)
 703     (m_ty, _b_ty) = tcSplitAppTy result_ty
 704
 705     goL [] = dsLExpr body
 706     goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
 707
 708     go _ (ExprStmt rhs then_expr _) stmts
 709       = do { rhs2 <- dsLExpr rhs
 710            ; case tcSplitAppTy_maybe (exprType rhs2) of
 711                 Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
 712                 _                                 -> return ()
 713            ; then_expr2 <- dsExpr then_expr
 714            ; rest <- goL stmts
 715            ; return (mkApps then_expr2 [rhs2, rest]) }
 716
 717     go _ (LetStmt binds) stmts
 718       = do { rest <- goL stmts
 719            ; dsLocalBinds binds rest }
 720
 721     go _ (BindStmt pat rhs bind_op fail_op) stmts
 722       = do  { body     <- goL stmts
 723             ; rhs'     <- dsLExpr rhs
 724             ; bind_op' <- dsExpr bind_op
 725             ; var   <- selectSimpleMatchVarL pat
 726             ; let bind_ty = exprType bind_op'   -- rhs -> (pat -> res1) -> res2
 727                   res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
 728             ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
 729                                       res1_ty (cantFailMatchResult body)
 730             ; match_code <- handle_failure pat match fail_op
 731             ; return (mkApps bind_op' [rhs', Lam var match_code]) }
 732
 733     go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
 734                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op
 735                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
 736                     , recS_rec_rets = rec_rets, recS_dicts = binds }) stmts
 737       = ASSERT( length rec_ids > 0 )
 738         goL (new_bind_stmt : let_stmt : stmts)
 739       where
 740         -- returnE <- dsExpr return_id
 741         -- mfixE <- dsExpr mfix_id
 742         new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
 743                                          bind_op
 744                                              noSyntaxExpr  -- Tuple cannot fail
 745
 746         let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
 747
 748         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
 749         rec_tup_pats = map nlVarPat tup_ids
 750         later_pats   = rec_tup_pats
 751         rets         = map noLoc rec_rets
 752
 753         mfix_app   = nlHsApp (noLoc mfix_op) mfix_arg
 754         mfix_arg   = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
 755                                              (mkFunTy tup_ty body_ty))
 756         mfix_pat   = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
 757         body       = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
 758         return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
 759         body_ty    = mkAppTy m_ty tup_ty
 760         tup_ty     = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
 761
 762     -- In a do expression, pattern-match failure just calls
 763     -- the monadic 'fail' rather than throwing an exception
 764     handle_failure pat match fail_op
 765       | matchCanFail match
 766       = do { fail_op' <- dsExpr fail_op
 767            ; fail_msg <- mkStringExpr (mk_fail_msg pat)
 768            ; extractMatchResult match (App fail_op' fail_msg) }
 769       | otherwise
 770       = extractMatchResult match (error "It can't fail")
 771
 772 mk_fail_msg :: Located e -> String
 773 mk_fail_msg pat = "Pattern match failure in do expression at " ++
 774                   showSDoc (ppr (getLoc pat))
 775 \end{code}
 776
 777 Translation for RecStmt's:
 778 -----------------------------
 779 We turn (RecStmt [v1,..vn] stmts) into:
 780
 781   (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
 782                                       return (v1,..vn))
 783
 784 \begin{code}
 785 dsMDo   :: PostTcTable
 786         -> [LStmt Id]
 787         -> LHsExpr Id
 788         -> Type                 -- Type of the whole expression
 789         -> DsM CoreExpr
 790
 791 dsMDo tbl stmts body result_ty
 792   = goL stmts
 793   where
 794     goL [] = dsLExpr body
 795     goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
 796
 797     (m_ty, b_ty) = tcSplitAppTy result_ty       -- result_ty must be of the form (m b)
 798     mfix_id   = lookupEvidence tbl mfixName
 799     return_id = lookupEvidence tbl returnMName
 800     bind_id   = lookupEvidence tbl bindMName
 801     then_id   = lookupEvidence tbl thenMName
 802     fail_id   = lookupEvidence tbl failMName
 803     ctxt      = MDoExpr tbl
 804
 805     go _ (LetStmt binds) stmts
 806       = do { rest <- goL stmts
 807            ; dsLocalBinds binds rest }
 808
 809     go _ (ExprStmt rhs _ rhs_ty) stmts
 810       = do { rhs2 <- dsLExpr rhs
 811            ; warnDiscardedDoBindings rhs m_ty rhs_ty
 812            ; rest <- goL stmts
 813            ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
 814
 815     go _ (BindStmt pat rhs _ _) stmts
 816       = do { body  <- goL stmts
 817            ; var   <- selectSimpleMatchVarL pat
 818            ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
 819                                   result_ty (cantFailMatchResult body)
 820            ; fail_msg   <- mkStringExpr (mk_fail_msg pat)
 821            ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
 822            ; match_code <- extractMatchResult match fail_expr
 823
 824            ; rhs'       <- dsLExpr rhs
 825            ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
 826                                              rhs', Lam var match_code]) }
 827
 828     go loc (RecStmt rec_stmts later_ids rec_ids _ _ _ rec_rets binds) stmts
 829       = ASSERT( length rec_ids > 0 )
 830         ASSERT( length rec_ids == length rec_rets )
 831         pprTrace "dsMDo" (ppr later_ids) $
 832          goL (new_bind_stmt : let_stmt : stmts)
 833       where
 834         new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
 835         let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
 836
 837
 838                 -- Remove the later_ids that appear (without fancy coercions)
 839                 -- in rec_rets, because there's no need to knot-tie them separately
 840                 -- See Note [RecStmt] in HsExpr
 841         later_ids'   = filter (`notElem` mono_rec_ids) later_ids
 842         mono_rec_ids = [ id | HsVar id <- rec_rets ]
 843
 844         mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg
 845         mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
 846                                              (mkFunTy tup_ty body_ty))
 847
 848         -- The rec_tup_pat must bind the rec_ids only; remember that the
 849         --      trimmed_laters may share the same Names
 850         -- Meanwhile, the later_pats must bind the later_vars
 851         rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
 852         later_pats   = map nlVarPat    later_ids' ++ map mk_later_pat rec_ids
 853         rets         = map nlHsVar     later_ids' ++ map noLoc rec_rets
 854
 855         mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
 856         body     = noLoc $ HsDo ctxt rec_stmts return_app body_ty
 857         body_ty = mkAppTy m_ty tup_ty
 858         tup_ty  = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids))  -- Deals with singleton case
 859
 860         return_app  = nlHsApp (nlHsTyApp return_id [tup_ty])
 861                               (mkLHsTupleExpr rets)
 862
 863         mk_wild_pat :: Id -> LPat Id
 864         mk_wild_pat v = noLoc $ WildPat $ idType v
 865
 866         mk_later_pat :: Id -> LPat Id
 867         mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
 868                        | otherwise           = nlVarPat v
 869
 870         mk_tup_pat :: [LPat Id] -> LPat Id
 871         mk_tup_pat [p] = p
 872         mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed
 873 \end{code}
 874
 875
 876 %************************************************************************
 877 %*                                                                      *
 878 \subsection{Errors and contexts}
 879 %*                                                                      *
 880 %************************************************************************
 881
 882 \begin{code}
 883 -- Warn about certain types of values discarded in monadic bindings (#3263)
 884 warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
 885 warnDiscardedDoBindings rhs container_ty returning_ty = do {
 886           -- Warn about discarding non-() things in 'monadic' binding
 887         ; warn_unused <- doptDs Opt_WarnUnusedDoBind
 888         ; if warn_unused && not (returning_ty `tcEqType` unitTy)
 889            then warnDs (unusedMonadBind rhs returning_ty)
 890            else do {
 891           -- Warn about discarding m a things in 'monadic' binding of the same type,
 892           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
 893         ; warn_wrong <- doptDs Opt_WarnWrongDoBind
 894         ; case tcSplitAppTy_maybe returning_ty of
 895                   Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
 896                                                             warnDs (wrongMonadBind rhs returning_ty)
 897                   _ -> return () } }
 898
 899 unusedMonadBind :: LHsExpr Id -> Type -> SDoc
 900 unusedMonadBind rhs returning_ty
 901   = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
 902     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
 903     ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
 904
 905 wrongMonadBind :: LHsExpr Id -> Type -> SDoc
 906 wrongMonadBind rhs returning_ty
 907   = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
 908     ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
 909     ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
 910 \end{code}