DsExpr.hs 46.6 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Simon Marlow's avatar
Simon Marlow committed
5 6

Desugaring exporessions.
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

Richard Eisenberg's avatar
Richard Eisenberg committed
9
{-# LANGUAGE CPP, MultiWayIf #-}
10

Richard Eisenberg's avatar
Richard Eisenberg committed
11
module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
12
              , dsValBinds, dsLit, dsSyntaxExpr ) where
13

14
#include "HsVersions.h"
mnislaih's avatar
mnislaih committed
15

Simon Marlow's avatar
Simon Marlow committed
16 17 18 19 20 21 22
import Match
import MatchLit
import DsBinds
import DsGRHSs
import DsListComp
import DsUtils
import DsArrows
23
import DsMonad
24
import Name
25
import NameEnv
26
import FamInstEnv( topNormaliseType )
Simon Marlow's avatar
Simon Marlow committed
27
import DsMeta
28
import HsSyn
29 30

-- NB: The desugarer, which straddles the source and Core worlds, sometimes
Simon Marlow's avatar
Simon Marlow committed
31 32
--     needs to see source types
import TcType
33
import TcEvidence
34
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
35
import TcHsSyn
Simon Marlow's avatar
Simon Marlow committed
36
import Type
37
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
38
import CoreUtils
39
import MkCore
Simon Marlow's avatar
Simon Marlow committed
40

41
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
42 43
import CostCentre
import Id
Richard Eisenberg's avatar
Richard Eisenberg committed
44
import MkId
45
import Module
cactus's avatar
cactus committed
46
import ConLike
Simon Marlow's avatar
Simon Marlow committed
47 48
import DataCon
import TysWiredIn
Facundo Domínguez's avatar
Facundo Domínguez committed
49
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
50
import BasicTypes
51
import Maybes
52
import VarEnv
Simon Marlow's avatar
Simon Marlow committed
53 54 55
import SrcLoc
import Util
import Bag
56
import Outputable
Matthew Pickering's avatar
Matthew Pickering committed
57
import PatSyn
58 59

import Control.Monad
60

Austin Seipp's avatar
Austin Seipp committed
61 62 63
{-
************************************************************************
*                                                                      *
64
                dsLocalBinds, dsValBinds
Austin Seipp's avatar
Austin Seipp committed
65 66 67
*                                                                      *
************************************************************************
-}
68

Richard Eisenberg's avatar
Richard Eisenberg committed
69 70 71 72 73
dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr
dsLocalBinds (L _   EmptyLocalBinds)    body = return body
dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $
                                               dsValBinds binds body
dsLocalBinds (L _ (HsIPBinds binds))    body = dsIPBinds  binds body
74 75

-------------------------
Richard Eisenberg's avatar
Richard Eisenberg committed
76
-- caller sets location
77
dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
78
dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
Simon Peyton Jones's avatar
Simon Peyton Jones committed
79
dsValBinds (ValBindsIn {})       _    = panic "dsValBinds ValBindsIn"
80 81

-------------------------
82
dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
83
dsIPBinds (IPBinds ip_binds ev_binds) body
84 85
  = do  { ds_binds <- dsTcEvBinds ev_binds
        ; let inner = mkCoreLets ds_binds body
Austin Seipp's avatar
Austin Seipp committed
86
                -- The dict bindings may not be in
87 88
                -- dependency order; hence Rec
        ; foldrM ds_ip_bind inner ip_binds }
89
  where
90
    ds_ip_bind (L _ (IPBind ~(Right n) e)) body
91
      = do e' <- dsLExpr e
92
           return (Let (NonRec n e') body)
93

94
-------------------------
Richard Eisenberg's avatar
Richard Eisenberg committed
95
-- caller sets location
96
ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
97
-- Special case for bindings which bind unlifted variables
98 99
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
100
-- Silently ignore INLINE and SPECIALISE pragmas...
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
101
ds_val_bind (NonRecursive, hsbinds) body
Richard Eisenberg's avatar
Richard Eisenberg committed
102
  | [L loc bind] <- bagToList hsbinds
103 104 105 106
        -- Non-recursive, non-overloaded bindings only come in ones
        -- ToDo: in some bizarre case it's conceivable that there
        --       could be dict binds in the 'binds'.  (See the notes
        --       below.  Then pattern-match would fail.  Urk.)
Richard Eisenberg's avatar
Richard Eisenberg committed
107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
  , isUnliftedHsBind bind
  = putSrcSpanDs loc $
     -- see Note [Strict binds checks] in DsBinds
    if is_polymorphic bind
    then errDsCoreExpr (poly_bind_err bind)
            -- data Ptr a = Ptr Addr#
            -- f x = let p@(Ptr y) = ... in ...
            -- Here the binding for 'p' is polymorphic, but does
            -- not mix with an unlifted binding for 'y'.  You should
            -- use a bang pattern.  Trac #6078.

    else do { when (looksLazyPatBind bind) $
              warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)
        -- Complain about a binding that looks lazy
        --    e.g.    let I# y = x in ...
        -- Remember, in checkStrictBinds we are going to do strict
        -- matching, so (for software engineering reasons) we insist
        -- that the strictness is manifest on each binding
        -- However, lone (unboxed) variables are ok


            ; dsUnliftedBind bind body }
  where
    is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
                     = not (null tvs && null evs)
    is_polymorphic (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs })
                     = not (null tvs && null evs)
    is_polymorphic _ = False

    unlifted_must_be_bang bind
      = hang (text "Pattern bindings containing unlifted types should use" $$
              text "an outermost bang pattern:")
           2 (ppr bind)

    poly_bind_err bind
      = hang (text "You can't mix polymorphic and unlifted bindings:")
           2 (ppr bind) $$
        text "Probable fix: add a type signature"

ds_val_bind (is_rec, binds) _body
  | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in DsBinds
  = ASSERT( isRec is_rec )
    errDsCoreExpr $
    hang (text "Recursive bindings for unlifted types aren't allowed:")
       2 (vcat (map ppr (bagToList binds)))
152

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
153
-- Ordinary case for bindings; none should be unlifted
Richard Eisenberg's avatar
Richard Eisenberg committed
154 155 156 157 158
ds_val_bind (is_rec, binds) body
  = do  { MASSERT( isRec is_rec || isSingletonBag binds )
               -- we should never produce a non-recursive list of multiple binds

        ; (force_vars,prs) <- dsLHsBinds binds
159
        ; let body' = foldr seqVar body force_vars
Richard Eisenberg's avatar
Richard Eisenberg committed
160
        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
161
          case prs of
162
            [] -> return body
163
            _  -> return (Let (Rec prs) body') }
Austin Seipp's avatar
Austin Seipp committed
164
        -- Use a Rec regardless of is_rec.
165 166 167 168 169 170 171 172 173
        -- Why? Because it allows the binds to be all
        -- mixed up, which is what happens in one rare case
        -- Namely, for an AbsBind with no tyvars and no dicts,
        --         but which does have dictionary bindings.
        -- See notes with TcSimplify.inferLoop [NO TYVARS]
        -- It turned out that wrapping a Rec here was the easiest solution
        --
        -- NB The previous case dealt with unlifted bindings, so we
        --    only have to deal with lifted ones now; so Rec is ok
174

175
------------------
176 177
dsUnliftedBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
178 179
               , abs_exports = exports
               , abs_ev_binds = ev_binds
180
               , abs_binds = lbinds }) body
181
  = do { let body1 = foldr bind_export body exports
182
             bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
183
       ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
Austin Seipp's avatar
Austin Seipp committed
184
                            body1 lbinds
185
       ; ds_binds <- dsTcEvBinds_s ev_binds
186
       ; return (mkCoreLets ds_binds body2) }
187

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
188 189 190 191 192 193 194 195 196
dsUnliftedBind (AbsBindsSig { abs_tvs         = []
                            , abs_ev_vars     = []
                            , abs_sig_export  = poly
                            , abs_sig_ev_bind = ev_bind
                            , abs_sig_bind    = L _ bind }) body
  = do { ds_binds <- dsTcEvBinds ev_bind
       ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body
       ; return (mkCoreLets ds_binds body') }

197
dsUnliftedBind (FunBind { fun_id = L l fun
198 199 200 201 202
                        , fun_matches = matches
                        , fun_co_fn = co_fn
                        , fun_tick = tick }) body
               -- Can't be a bang pattern (that looks like a PatBind)
               -- so must be simply unboxed
Ben Gamari's avatar
Ben Gamari committed
203
  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))
204
                                     Nothing matches
205 206
       ; MASSERT( null args ) -- Functions aren't lifted
       ; MASSERT( isIdHsWrapper co_fn )
207
       ; let rhs' = mkOptTickBox tick rhs
208 209
       ; return (bindNonRec fun rhs' body) }

210
dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
211 212
  =     -- let C x# y# = rhs in body
        -- ==> case rhs of C x# y# -> body
213 214
    do { rhs <- dsGuarded grhss ty
       ; let upat = unLoc pat
Austin Seipp's avatar
Austin Seipp committed
215
             eqn = EqnInfo { eqn_pats = [upat],
216 217 218
                             eqn_rhs = cantFailMatchResult body }
       ; var    <- selectMatchVar upat
       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
219
       ; return (bindNonRec var rhs result) }
220

221
dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
222

Austin Seipp's avatar
Austin Seipp committed
223 224 225
{-
************************************************************************
*                                                                      *
226
\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
Austin Seipp's avatar
Austin Seipp committed
227 228 229
*                                                                      *
************************************************************************
-}
230

231
dsLExpr :: LHsExpr Id -> DsM CoreExpr
mnislaih's avatar
mnislaih committed
232

Richard Eisenberg's avatar
Richard Eisenberg committed
233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252
dsLExpr (L loc e)
  = putSrcSpanDs loc $
    do { core_expr <- dsExpr e
   -- uncomment this check to test the hsExprType function in TcHsSyn
   --    ; MASSERT2( exprType core_expr `eqType` hsExprType e
   --              , ppr e <+> dcolon <+> ppr (hsExprType e) $$
   --                ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )
       ; return core_expr }

-- | Variant of 'dsLExpr' that ensures that the result is not levity
-- polymorphic. This should be used when the resulting expression will
-- be an argument to some other function.
-- See Note [Levity polymorphism checking] in DsMonad
-- See Note [Levity polymorphism invariants] in CoreSyn
dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr
dsLExprNoLP (L loc e)
  = putSrcSpanDs loc $
    do { e' <- dsExpr e
       ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
       ; return e' }
253 254

dsExpr :: HsExpr Id -> DsM CoreExpr
255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271
dsExpr = ds_expr False

ds_expr :: Bool   -- are we directly inside an HsWrap?
                  -- See Wrinkle in Note [Detecting forced eta expansion]
        -> HsExpr Id -> DsM CoreExpr
ds_expr _ (HsPar e)              = dsLExpr e
ds_expr _ (ExprWithTySigOut e _) = dsLExpr e
ds_expr w (HsVar (L _ var))      = dsHsVar w var
ds_expr _ (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
ds_expr w (HsConLikeOut con)     = dsConLike w con
ds_expr _ (HsIPVar _)            = panic "dsExpr: HsIPVar"
ds_expr _ (HsOverLabel{})        = panic "dsExpr: HsOverLabel"
ds_expr _ (HsLit lit)            = dsLit lit
ds_expr _ (HsOverLit lit)        = dsOverLit lit

ds_expr _ (HsWrap co_fn e)
  = do { e' <- ds_expr True e
Simon Peyton Jones's avatar
Simon Peyton Jones committed
272
       ; wrap' <- dsHsWrapper co_fn
273
       ; dflags <- getDynFlags
Simon Peyton Jones's avatar
Simon Peyton Jones committed
274
       ; let wrapped_e = wrap' e'
275 276 277
             wrapped_ty = exprType wrapped_e
       ; checkForcedEtaExpansion e wrapped_ty -- See Note [Detecting forced eta expansion]
       ; warnAboutIdentities dflags e' wrapped_ty
278
       ; return wrapped_e }
279

280
ds_expr _ (NegApp (L loc (HsOverLit lit@(OverLit { ol_val = HsIntegral i })))
281
                  neg_expr)
282 283 284
  = do { expr' <- putSrcSpanDs loc $ do
          { dflags <- getDynFlags
          ; warnAboutOverflowedLiterals dflags
285
                                        (lit { ol_val = HsIntegral (negateIntegralLit i) })
286 287 288
          ; dsOverLit' dflags lit }
       ; dsSyntaxExpr neg_expr [expr'] }

289
ds_expr _ (NegApp expr neg_expr)
290 291
  = do { expr' <- dsLExpr expr
       ; dsSyntaxExpr neg_expr [expr'] }
292

293
ds_expr _ (HsLam a_Match)
294
  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
295

296
ds_expr _ (HsLamCase matches)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
297 298
  = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
       ; return $ Lam discrim_var matching_code }
299

300
ds_expr _ e@(HsApp fun arg)
301 302 303
  = do { fun' <- dsLExpr fun
       ; dsWhenNoErrs (dsLExprNoLP arg)
                      (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
304

305
ds_expr _ (HsAppTypeOut e _)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
306
    -- ignore type arguments here; they're in the wrappers instead at this point
307
  = dsLExpr e
308

309

Austin Seipp's avatar
Austin Seipp committed
310
{-
Simon Peyton Jones's avatar
Simon Peyton Jones committed
311 312 313 314 315 316 317 318 319 320 321 322 323 324 325
Note [Desugaring vars]
~~~~~~~~~~~~~~~~~~~~~~
In one situation we can get a *coercion* variable in a HsVar, namely
the support method for an equality superclass:
   class (a~b) => C a b where ...
   instance (blah) => C (T a) (T b) where ..
Then we get
   $dfCT :: forall ab. blah => C (T a) (T b)
   $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)

   $c$p1C :: forall ab. blah => (T a ~ T b)
   $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g

That 'g' in the 'in' part is an evidence variable, and when
converting to core it must become a CO.
Austin Seipp's avatar
Austin Seipp committed
326

327 328
Operator sections.  At first it looks as if we can convert
\begin{verbatim}
329
        (expr op)
330
\end{verbatim}
331
to
332
\begin{verbatim}
333
        \x -> op expr x
334 335 336 337 338
\end{verbatim}

But no!  expr might be a redex, and we can lose laziness badly this
way.  Consider
\begin{verbatim}
339
        map (expr op) xs
340 341 342
\end{verbatim}
for example.  So we convert instead to
\begin{verbatim}
343
        let y = expr in \x -> op y x
344 345 346
\end{verbatim}
If \tr{expr} is actually just a variable, say, then the simplifier
will sort it out.
Austin Seipp's avatar
Austin Seipp committed
347
-}
348

349
ds_expr _ e@(OpApp e1 op _ e2)
350
  = -- for the type of y, we need the type of op's 2nd argument
351 352 353
    do { op' <- dsLExpr op
       ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
                      (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
Austin Seipp's avatar
Austin Seipp committed
354

355
ds_expr _ (SectionL expr op)       -- Desugar (e !) to ((!) e)
356 357 358
  = do { op' <- dsLExpr op
       ; dsWhenNoErrs (dsLExprNoLP expr)
                      (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
359

360
-- dsLExpr (SectionR op expr)   -- \ x -> op x expr
361
ds_expr _ e@(SectionR op expr) = do
362
    core_op <- dsLExpr op
sof's avatar
sof committed
363
    -- for the type of x, we need the type of op's 2nd argument
364 365 366
    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
        -- See comment with SectionL
    y_core <- dsLExpr expr
367 368 369 370
    dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])
                 (\[x_id, y_id] -> bindNonRec y_id y_core $
                                   Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
                                                          core_op [Var x_id, Var y_id]))
371

372
ds_expr _ (ExplicitTuple tup_args boxity)
373
  = do { let go (lam_vars, args) (L _ (Missing ty))
374
                    -- For every missing expression, we need
375
                    -- another lambda in the desugaring.
Richard Eisenberg's avatar
Richard Eisenberg committed
376
               = do { lam_var <- newSysLocalDsNoLP ty
377
                    ; return (lam_var : lam_vars, Var lam_var : args) }
378
             go (lam_vars, args) (L _ (Present expr))
379
                    -- Expressions that are present don't generate
380 381 382 383 384
                    -- lambdas, just arguments.
               = do { core_expr <- dsLExpr expr
                    ; return (lam_vars, core_expr : args) }

       ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
385
                -- The reverse is because foldM goes left-to-right
386

387
       ; return $ mkCoreLams lam_vars $
388
                  mkCoreTupBoxity boxity args }
389

390
ds_expr _ (ExplicitSum alt arity expr types)
391 392 393 394 395 396
  = do { core_expr <- dsLExpr expr
       ; return $ mkCoreConApps (sumDataCon alt arity)
                                (map (Type . getRuntimeRep "dsExpr ExplicitSum") types ++
                                 map Type types ++
                                 [core_expr]) }

397
ds_expr _ (HsSCC _ cc expr@(L loc _)) = do
Alan Zimmerman's avatar
Alan Zimmerman committed
398 399 400 401 402 403
    dflags <- getDynFlags
    if gopt Opt_SccProfilingOn dflags
      then do
        mod_name <- getModule
        count <- goptM Opt_ProfCountEntries
        uniq <- newUnique
404
        Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True)
Alan Zimmerman's avatar
Alan Zimmerman committed
405 406 407
               <$> dsLExpr expr
      else dsLExpr expr

408
ds_expr _ (HsCoreAnn _ _ expr)
409
  = dsLExpr expr
410

411
ds_expr _ (HsCase discrim matches)
412
  = do { core_discrim <- dsLExpr discrim
413
       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
414
       ; return (bindNonRec discrim_var core_discrim matching_code) }
415

416 417
-- Pepe: The binds are in scope in the body but NOT in the binding group
--       This is to avoid silliness in breakpoints
418
ds_expr _ (HsLet binds body) = do
419
    body' <- dsLExpr body
420
    dsLocalBinds binds body'
421

chak's avatar
chak committed
422 423 424
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
425 426 427 428 429 430 431 432
ds_expr _ (HsDo ListComp     (L _ stmts) res_ty) = dsListComp stmts res_ty
ds_expr _ (HsDo PArrComp     (L _ stmts) _)      = dsPArrComp (map unLoc stmts)
ds_expr _ (HsDo DoExpr       (L _ stmts) _)      = dsDo stmts
ds_expr _ (HsDo GhciStmtCtxt (L _ stmts) _)      = dsDo stmts
ds_expr _ (HsDo MDoExpr      (L _ stmts) _)      = dsDo stmts
ds_expr _ (HsDo MonadComp    (L _ stmts) _)      = dsMonadComp stmts

ds_expr _ (HsIf mb_fun guard_expr then_expr else_expr)
433 434 435 436
  = do { pred <- dsLExpr guard_expr
       ; b1 <- dsLExpr then_expr
       ; b2 <- dsLExpr else_expr
       ; case mb_fun of
437
           Just fun -> dsSyntaxExpr fun [pred, b1, b2]
438
           Nothing  -> return $ mkIfThenElse pred b1 b2 }
439

440
ds_expr _ (HsMultiIf res_ty alts)
441 442 443 444 445 446 447 448 449 450
  | null alts
  = mkErrorExpr

  | otherwise
  = do { match_result <- liftM (foldr1 combineMatchResults)
                               (mapM (dsGRHS IfAlt res_ty) alts)
       ; error_expr   <- mkErrorExpr
       ; extractMatchResult match_result error_expr }
  where
    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
451
                               (text "multi-way if")
452

Austin Seipp's avatar
Austin Seipp committed
453
{-
454 455
\noindent
\underline{\bf Various data construction things}
Austin Seipp's avatar
Austin Seipp committed
456 457 458
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-}

459
ds_expr _ (ExplicitList elt_ty wit xs)
460
  = dsExplicitList elt_ty wit xs
461

462 463
-- We desugar [:x1, ..., xn:] as
--   singletonP x1 +:+ ... +:+ singletonP xn
chak's avatar
chak committed
464
--
465
ds_expr _ (ExplicitPArr ty []) = do
466
    emptyP <- dsDPHBuiltin emptyPVar
467
    return (Var emptyP `App` Type ty)
468
ds_expr _ (ExplicitPArr ty xs) = do
469 470
    singletonP <- dsDPHBuiltin singletonPVar
    appP       <- dsDPHBuiltin appPVar
Richard Eisenberg's avatar
Richard Eisenberg committed
471
    xs'        <- mapM dsLExprNoLP xs
472 473 474
    let unary  fn x   = mkApps (Var fn) [Type ty, x]
        binary fn x y = mkApps (Var fn) [Type ty, x, y]

475
    return . foldr1 (binary appP) $ map (unary singletonP) xs'
chak's avatar
chak committed
476

477
ds_expr _ (ArithSeq expr witness seq)
478 479
  = case witness of
     Nothing -> dsArithSeq expr seq
480 481
     Just fl -> do { newArithSeq <- dsArithSeq expr seq
                   ; dsSyntaxExpr fl [newArithSeq] }
482

483
ds_expr _ (PArrSeq expr (FromTo from to))
Richard Eisenberg's avatar
Richard Eisenberg committed
484
  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to]
485

486
ds_expr _ (PArrSeq expr (FromThenTo from thn to))
Richard Eisenberg's avatar
Richard Eisenberg committed
487
  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to]
chak's avatar
chak committed
488

489
ds_expr _ (PArrSeq _ _)
chak's avatar
chak committed
490 491 492
  = panic "DsExpr.dsExpr: Infinite parallel array!"
    -- the parser shouldn't have generated it and the renamer and typechecker
    -- shouldn't have let it through
493

Facundo Domínguez's avatar
Facundo Domínguez committed
494
{-
495 496 497
Static Pointers
~~~~~~~~~~~~~~~

498 499
See Note [Grand plan for static forms] in StaticPtrTable for an overview.

Facundo Domínguez's avatar
Facundo Domínguez committed
500 501
    g = ... static f ...
==>
502
    g = ... makeStatic loc f ...
Facundo Domínguez's avatar
Facundo Domínguez committed
503 504
-}

505
ds_expr _ (HsStatic _ expr@(L loc _)) = do
Richard Eisenberg's avatar
Richard Eisenberg committed
506
    expr_ds <- dsLExprNoLP expr
Facundo Domínguez's avatar
Facundo Domínguez committed
507
    let ty = exprType expr_ds
508
    makeStaticId <- dsLookupGlobalId makeStaticName
Facundo Domínguez's avatar
Facundo Domínguez committed
509 510 511 512 513 514 515

    dflags <- getDynFlags
    let (line, col) = case loc of
           RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
                            , srcLocCol  $ realSrcSpanStart r
                            )
           _             -> (0, 0)
516
        srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
Facundo Domínguez's avatar
Facundo Domínguez committed
517 518 519
                     [ Type intTy              , Type intTy
                     , mkIntExprInt dflags line, mkIntExprInt dflags col
                     ]
520

521 522
    putSrcSpanDs loc $ return $
      mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
523

Austin Seipp's avatar
Austin Seipp committed
524
{-
525 526
\noindent
\underline{\bf Record construction and update}
Austin Seipp's avatar
Austin Seipp committed
527
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
528
For record construction we do this (assuming T has three arguments)
529
\begin{verbatim}
530
        T { op2 = e }
531
==>
Austin Seipp's avatar
Austin Seipp committed
532
        let err = /\a -> recConErr a
533
        T (recConErr t1 "M.hs/230/op1")
Austin Seipp's avatar
Austin Seipp committed
534
          e
535
          (recConErr t1 "M.hs/230/op3")
536
\end{verbatim}
537
@recConErr@ then converts its argument string into a proper message
538
before printing it as
539
\begin{verbatim}
540
        M.hs, line 230: missing field op1 was evaluated
541
\end{verbatim}
542

543 544
We also handle @C{}@ as valid construction syntax for an unlabelled
constructor @C@, setting all of @C@'s fields to bottom.
Austin Seipp's avatar
Austin Seipp committed
545
-}
546

547 548
ds_expr _ (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds
                     , rcon_con_like = con_like })
549 550 551 552 553
  = do { con_expr' <- dsExpr con_expr
       ; let
             (arg_tys, _) = tcSplitFunTys (exprType con_expr')
             -- A newtype in the corner should be opaque;
             -- hence TcType.tcSplitFunTys
554

555 556 557
             mk_arg (arg_ty, fl)
               = case findField (rec_flds rbinds) (flSelector fl) of
                   (rhs:rhss) -> ASSERT( null rhss )
Richard Eisenberg's avatar
Richard Eisenberg committed
558
                                 dsLExprNoLP rhs
559 560
                   []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
             unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
561

562
             labels = conLikeFieldLabels con_like
Austin Seipp's avatar
Austin Seipp committed
563

564 565 566
       ; con_args <- if null labels
                     then mapM unlabelled_bottom arg_tys
                     else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
Austin Seipp's avatar
Austin Seipp committed
567

568
       ; return (mkCoreApps con_expr' con_args) }
569

Austin Seipp's avatar
Austin Seipp committed
570
{-
571
Record update is a little harder. Suppose we have the decl:
572
\begin{verbatim}
573 574 575
        data T = T1 {op1, op2, op3 :: Int}
               | T2 {op4, op2 :: Int}
               | T3
576
\end{verbatim}
577
Then we translate as follows:
578
\begin{verbatim}
579
        r { op2 = e }
580
===>
581 582 583 584
        let op2 = e in
        case r of
          T1 op1 _ op3 -> T1 op1 op2 op3
          T2 op4 _     -> T2 op4 op2
585
          other        -> recUpdError "M.hs/230"
586 587
\end{verbatim}
It's important that we use the constructor Ids for @T1@, @T2@ etc on the
588
RHSs, and do not generate a Core constructor application directly, because the constructor
589 590 591
might do some argument-evaluation first; and may have to throw away some
dictionaries.

592 593
Note [Update for GADTs]
~~~~~~~~~~~~~~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
594
Consider
595
   data T a b where
596
     T1 :: { f1 :: a } -> T a Int
597

Austin Seipp's avatar
Austin Seipp committed
598
Then the wrapper function for T1 has type
599 600 601 602
   $WT1 :: a -> T a Int
But if x::T a b, then
   x { f1 = v } :: T a b   (not T a Int!)
So we need to cast (T a Int) to (T a b).  Sigh.
603

Austin Seipp's avatar
Austin Seipp committed
604
-}
605

606 607 608 609
ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
                          , rupd_cons = cons_to_upd
                          , rupd_in_tys = in_inst_tys, rupd_out_tys = out_inst_tys
                          , rupd_wrap = dict_req_wrap } )
610
  | null fields
611
  = dsLExpr record_expr
612
  | otherwise
613
  = ASSERT2( notNull cons_to_upd, ppr expr )
614

615 616 617 618 619 620 621 622
    do  { record_expr' <- dsLExpr record_expr
        ; field_binds' <- mapM ds_field fields
        ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
              upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']

        -- It's important to generate the match with matchWrapper,
        -- and the right hand sides with applications of the wrapper Id
        -- so that everything works when we are doing fancy unboxing on the
Gabor Greif's avatar
Gabor Greif committed
623
        -- constructor arguments.
624
        ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
625
        ; ([discrim_var], matching_code)
626 627 628 629 630
                <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts
                                                   , mg_arg_tys = [in_ty]
                                                   , mg_res_ty = out_ty, mg_origin = FromSource })
                                                   -- FromSource is not strictly right, but we
                                                   -- want incomplete pattern-match warnings
631 632 633

        ; return (add_field_binds field_binds' $
                  bindNonRec discrim_var record_expr' matching_code) }
634
  where
Adam Gundry's avatar
Adam Gundry committed
635
    ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr)
636
      -- Clone the Id in the HsRecField, because its Name is that
Adam Gundry's avatar
Adam Gundry committed
637
      -- of the record selector, and we must not make that a local binder
638 639
      -- else we shadow other uses of the record selector
      -- Hence 'lcl_id'.  Cf Trac #2735
640
    ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
Adam Gundry's avatar
Adam Gundry committed
641
                                  ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
642 643
                                  ; lcl_id <- newSysLocalDs (idType fld_id)
                                  ; return (idName fld_id, lcl_id, rhs) }
644 645

    add_field_binds [] expr = expr
646
    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
647

Austin Seipp's avatar
Austin Seipp committed
648
        -- Awkwardly, for families, the match goes
649
        -- from instance type to family type
Matthew Pickering's avatar
Matthew Pickering committed
650 651 652 653 654 655
    (in_ty, out_ty) =
      case (head cons_to_upd) of
        RealDataCon data_con ->
          let tycon = dataConTyCon data_con in
          (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)
        PatSynCon pat_syn ->
656
          ( patSynInstResTy pat_syn in_inst_tys
Matthew Pickering's avatar
Matthew Pickering committed
657
          , patSynInstResTy pat_syn out_inst_tys)
658
    mk_alt upd_fld_env con
Austin Seipp's avatar
Austin Seipp committed
659
      = do { let (univ_tvs, ex_tvs, eq_spec,
Matthew Pickering's avatar
Matthew Pickering committed
660
                  prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
661
                 subst = zipTvSubst univ_tvs in_inst_tys
662 663 664

                -- I'm not bothering to clone the ex_tvs
           ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
Matthew Pickering's avatar
Matthew Pickering committed
665
           ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta)
666
           ; arg_ids    <- newSysLocalsDs (substTysUnchecked subst arg_tys)
Matthew Pickering's avatar
Matthew Pickering committed
667 668 669
           ; let field_labels = conLikeFieldLabels con
                 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
                                         field_labels arg_ids
Adam Gundry's avatar
Adam Gundry committed
670 671
                 mk_val_arg fl pat_arg_id
                     = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
Richard Eisenberg's avatar
Richard Eisenberg committed
672

673
                 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut con)
674
                        -- Reconstruct with the WrapId so that unpacking happens
Matthew Pickering's avatar
Matthew Pickering committed
675
                 -- The order here is because of the order in `TcPatSyn`.
676 677
                 wrap = mkWpEvVarApps theta_vars                                <.>
                        dict_req_wrap                                           <.>
678 679 680 681
                        mkWpTyApps    (mkTyVarTys ex_tvs)                       <.>
                        mkWpTyApps    [ ty
                                      | (tv, ty) <- univ_tvs `zip` out_inst_tys
                                      , not (tv `elemVarEnv` wrap_subst) ]
682 683 684 685
                 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args

                        -- Tediously wrap the application in a cast
                        -- Note [Update for GADTs]
Matthew Pickering's avatar
Matthew Pickering committed
686 687 688 689 690 691 692 693 694 695 696 697 698 699 700
                 wrapped_rhs =
                  case con of
                    RealDataCon data_con ->
                      let
                        wrap_co =
                          mkTcTyConAppCo Nominal
                            (dataConTyCon data_con)
                            [ lookup tv ty
                              | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
                        lookup univ_tv ty =
                          case lookupVarEnv wrap_subst univ_tv of
                            Just co' -> co'
                            Nothing  -> mkTcReflCo Nominal ty
                        in if null eq_spec
                             then rhs
701
                             else mkLHsWrap (mkWpCastN wrap_co) rhs
Matthew Pickering's avatar
Matthew Pickering committed
702 703 704 705 706
                    -- eq_spec is always null for a PatSynCon
                    PatSynCon _ -> rhs

                 wrap_subst =
                  mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
707 708
                           | (spec, eq_var) <- eq_spec `zip` eqs_vars
                           , let tv = eqSpecTyVar spec ]
Matthew Pickering's avatar
Matthew Pickering committed
709 710

                 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
711

Matthew Pickering's avatar
Matthew Pickering committed
712
                 pat = noLoc $ ConPatOut { pat_con = noLoc con
cactus's avatar
cactus committed
713
                                         , pat_tvs = ex_tvs
714 715 716
                                         , pat_dicts = eqs_vars ++ theta_vars
                                         , pat_binds = emptyTcEvBinds
                                         , pat_args = PrefixCon $ map nlVarPat arg_ids
717
                                         , pat_arg_tys = in_inst_tys
Matthew Pickering's avatar
Matthew Pickering committed
718
                                         , pat_wrap = req_wrap }
719
           ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
720

Austin Seipp's avatar
Austin Seipp committed
721
-- Here is where we desugar the Template Haskell brackets and escapes
722 723 724

-- Template Haskell stuff

725 726 727
ds_expr _ (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
ds_expr _ (HsTcBracketOut x ps) = dsBracket x ps
ds_expr _ (HsSpliceE s)  = pprPanic "dsExpr:splice" (ppr s)
728

729
-- Arrow notation extension
730
ds_expr _ (HsProc pat cmd) = dsProcExpr pat cmd
731

Austin Seipp's avatar
Austin Seipp committed
732
-- Hpc Support
andy@galois.com's avatar
andy@galois.com committed
733

734
ds_expr _ (HsTick tickish e) = do
andy@galois.com's avatar
andy@galois.com committed
735
  e' <- dsLExpr e
736
  return (Tick tickish e')
andy@galois.com's avatar
andy@galois.com committed
737 738 739 740 741 742 743 744

-- There is a problem here. The then and else branches
-- have no free variables, so they are open to lifting.
-- We need someway of stopping this.
-- This will make no difference to binary coverage
-- (did you go here: YES or NO), but will effect accurate
-- tick counting.

745
ds_expr _ (HsBinTick ixT ixF e) = do
andy@galois.com's avatar
andy@galois.com committed
746
  e2 <- dsLExpr e
747
  do { ASSERT(exprType e2 `eqType` boolTy)
andy@galois.com's avatar
andy@galois.com committed
748 749
       mkBinaryTickBox ixT ixF e2
     }
750

751
ds_expr _ (HsTickPragma _ _ _ expr) = do
Alan Zimmerman's avatar
Alan Zimmerman committed
752 753 754 755 756
  dflags <- getDynFlags
  if gopt Opt_Hpc dflags
    then panic "dsExpr:HsTickPragma"
    else dsLExpr expr

757
-- HsSyn constructs that just shouldn't be here:
758 759 760 761 762 763 764 765 766 767 768
ds_expr _ (ExprWithTySig {})  = panic "dsExpr:ExprWithTySig"
ds_expr _ (HsBracket     {})  = panic "dsExpr:HsBracket"
ds_expr _ (HsArrApp      {})  = panic "dsExpr:HsArrApp"
ds_expr _ (HsArrForm     {})  = panic "dsExpr:HsArrForm"
ds_expr _ (EWildPat      {})  = panic "dsExpr:EWildPat"
ds_expr _ (EAsPat        {})  = panic "dsExpr:EAsPat"
ds_expr _ (EViewPat      {})  = panic "dsExpr:EViewPat"
ds_expr _ (ELazyPat      {})  = panic "dsExpr:ELazyPat"
ds_expr _ (HsAppType     {})  = panic "dsExpr:HsAppType" -- removed by typechecker
ds_expr _ (HsDo          {})  = panic "dsExpr:HsDo"
ds_expr _ (HsRecFld      {})  = panic "dsExpr:HsRecFld"
769

770 771 772 773 774 775
------------------------------
dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (SyntaxExpr { syn_expr      = expr
                         , syn_arg_wraps = arg_wraps
                         , syn_res_wrap  = res_wrap })
             arg_exprs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
776 777 778 779
  = do { fun            <- dsExpr expr
       ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
       ; core_res_wrap  <- dsHsWrapper res_wrap
       ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
780 781
       ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])
                      (\_ -> core_res_wrap (mkApps fun wrapped_args)) }
Richard Eisenberg's avatar
Richard Eisenberg committed
782 783
  where
    mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
784

785
findField :: [LHsRecField Id arg] -> Name -> [arg]
Adam Gundry's avatar
Adam Gundry committed
786 787 788
findField rbinds sel
  = [hsRecFieldArg fld | L _ fld <- rbinds
                       , sel == idName (unLoc $ hsRecFieldId fld) ]
789

Austin Seipp's avatar
Austin Seipp committed
790
{-
sof's avatar
sof committed
791
%--------------------------------------------------------------------
792

793 794 795 796
Note [Desugaring explicit lists]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Explicit lists are desugared in a cleverer way to prevent some
fruitless allocations.  Essentially, whenever we see a list literal
797 798
[x_1, ..., x_n] we generate the corresponding expression in terms of
build:
799

800 801
Explicit lists (literals) are desugared to allow build/foldr fusion when
beneficial. This is a bit of a trade-off,
802

803 804
 * build/foldr fusion can generate far larger code than the corresponding
   cons-chain (e.g. see #11707)
Austin Seipp's avatar
Austin Seipp committed
805

806 807 808
 * even when it doesn't produce more code, build can still fail to fuse,
   requiring that the simplifier do more work to bring the expression
   back into cons-chain form; this costs compile time