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