DsExpr.hs 40.9 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
Gergő Érdi's avatar
Gergő Érdi 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
203 204
  = do { (args, rhs) <- matchWrapper (FunRhs (L l $ idName fun) Prefix)
                                     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
dsExpr (HsPar e)              = dsLExpr e
256
dsExpr (ExprWithTySigOut e _) = dsLExpr e
257 258
dsExpr (HsVar (L _ var))      = return (varToCoreExpr var)
                                -- See Note [Desugaring vars]
259
dsExpr (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
Richard Eisenberg's avatar
Richard Eisenberg committed
260
dsExpr (HsConLikeOut con)     = return (dsConLike con)
261
dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"
262
dsExpr (HsOverLabel{})        = panic "dsExpr: HsOverLabel"
263 264
dsExpr (HsLit lit)            = dsLit lit
dsExpr (HsOverLit lit)        = dsOverLit lit
265 266

dsExpr (HsWrap co_fn e)
267
  = do { e' <- dsExpr e
Simon Peyton Jones's avatar
Simon Peyton Jones committed
268
       ; wrap' <- dsHsWrapper co_fn
269
       ; dflags <- getDynFlags
Simon Peyton Jones's avatar
Simon Peyton Jones committed
270
       ; let wrapped_e = wrap' e'
271
       ; warnAboutIdentities dflags e' (exprType wrapped_e)
272
       ; return wrapped_e }
273

Austin Seipp's avatar
Austin Seipp committed
274
dsExpr (NegApp expr neg_expr)
275 276
  = do { expr' <- dsLExpr expr
       ; dsSyntaxExpr neg_expr [expr'] }
277

278
dsExpr (HsLam a_Match)
279
  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
280

Simon Peyton Jones's avatar
Simon Peyton Jones committed
281 282 283
dsExpr (HsLamCase matches)
  = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
       ; return $ Lam discrim_var matching_code }
284

285
dsExpr e@(HsApp fun arg)
Richard Eisenberg's avatar
Richard Eisenberg committed
286
  = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExprNoLP arg
287 288

dsExpr (HsAppTypeOut e _)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
289
    -- ignore type arguments here; they're in the wrappers instead at this point
290
  = dsLExpr e
291

292

Austin Seipp's avatar
Austin Seipp committed
293
{-
Simon Peyton Jones's avatar
Simon Peyton Jones committed
294 295 296 297 298 299 300 301 302 303 304 305 306 307 308
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
309

310 311
Operator sections.  At first it looks as if we can convert
\begin{verbatim}
312
        (expr op)
313
\end{verbatim}
314
to
315
\begin{verbatim}
316
        \x -> op expr x
317 318 319 320 321
\end{verbatim}

But no!  expr might be a redex, and we can lose laziness badly this
way.  Consider
\begin{verbatim}
322
        map (expr op) xs
323 324 325
\end{verbatim}
for example.  So we convert instead to
\begin{verbatim}
326
        let y = expr in \x -> op y x
327 328 329
\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
330
-}
331

332
dsExpr e@(OpApp e1 op _ e2)
333
  = -- for the type of y, we need the type of op's 2nd argument
Richard Eisenberg's avatar
Richard Eisenberg committed
334
    mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExprNoLP [e1, e2]
Austin Seipp's avatar
Austin Seipp committed
335

336
dsExpr (SectionL expr op)       -- Desugar (e !) to ((!) e)
Richard Eisenberg's avatar
Richard Eisenberg committed
337
  = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExprNoLP expr
338

339
-- dsLExpr (SectionR op expr)   -- \ x -> op x expr
340
dsExpr e@(SectionR op expr) = do
341
    core_op <- dsLExpr op
sof's avatar
sof committed
342
    -- for the type of x, we need the type of op's 2nd argument
343 344 345
    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
        -- See comment with SectionL
    y_core <- dsLExpr expr
Richard Eisenberg's avatar
Richard Eisenberg committed
346 347
    x_id <- newSysLocalDsNoLP x_ty
    y_id <- newSysLocalDsNoLP y_ty
348
    return (bindNonRec y_id y_core $
349
            Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id]))
350

351
dsExpr (ExplicitTuple tup_args boxity)
352
  = do { let go (lam_vars, args) (L _ (Missing ty))
353
                    -- For every missing expression, we need
354
                    -- another lambda in the desugaring.
Richard Eisenberg's avatar
Richard Eisenberg committed
355
               = do { lam_var <- newSysLocalDsNoLP ty
356
                    ; return (lam_var : lam_vars, Var lam_var : args) }
357
             go (lam_vars, args) (L _ (Present expr))
358
                    -- Expressions that are present don't generate
359 360 361 362 363
                    -- lambdas, just arguments.
               = do { core_expr <- dsLExpr expr
                    ; return (lam_vars, core_expr : args) }

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

366
       ; return $ mkCoreLams lam_vars $
367
                  mkCoreTupBoxity boxity args }
368

369 370 371 372 373 374 375
dsExpr (ExplicitSum alt arity expr types)
  = do { core_expr <- dsLExpr expr
       ; return $ mkCoreConApps (sumDataCon alt arity)
                                (map (Type . getRuntimeRep "dsExpr ExplicitSum") types ++
                                 map Type types ++
                                 [core_expr]) }

Alan Zimmerman's avatar
Alan Zimmerman committed
376 377 378 379 380 381 382
dsExpr (HsSCC _ cc expr@(L loc _)) = do
    dflags <- getDynFlags
    if gopt Opt_SccProfilingOn dflags
      then do
        mod_name <- getModule
        count <- goptM Opt_ProfCountEntries
        uniq <- newUnique
383
        Tick (ProfNote (mkUserCC (sl_fs cc) mod_name loc uniq) count True)
Alan Zimmerman's avatar
Alan Zimmerman committed
384 385 386 387
               <$> dsLExpr expr
      else dsLExpr expr

dsExpr (HsCoreAnn _ _ expr)
388
  = dsLExpr expr
389

390
dsExpr (HsCase discrim matches)
391
  = do { core_discrim <- dsLExpr discrim
392
       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
393
       ; return (bindNonRec discrim_var core_discrim matching_code) }
394

395 396
-- Pepe: The binds are in scope in the body but NOT in the binding group
--       This is to avoid silliness in breakpoints
Richard Eisenberg's avatar
Richard Eisenberg committed
397
dsExpr (HsLet binds body) = do
398
    body' <- dsLExpr body
399
    dsLocalBinds binds body'
400

chak's avatar
chak committed
401 402 403
-- 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.
--
404 405 406 407 408 409
dsExpr (HsDo ListComp     (L _ stmts) res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp     (L _ stmts) _)      = dsPArrComp (map unLoc stmts)
dsExpr (HsDo DoExpr       (L _ stmts) _)      = dsDo stmts
dsExpr (HsDo GhciStmtCtxt (L _ stmts) _)      = dsDo stmts
dsExpr (HsDo MDoExpr      (L _ stmts) _)      = dsDo stmts
dsExpr (HsDo MonadComp    (L _ stmts) _)      = dsMonadComp stmts
410

411 412 413 414 415
dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
  = do { pred <- dsLExpr guard_expr
       ; b1 <- dsLExpr then_expr
       ; b2 <- dsLExpr else_expr
       ; case mb_fun of
416
           Just fun -> dsSyntaxExpr fun [pred, b1, b2]
417
           Nothing  -> return $ mkIfThenElse pred b1 b2 }
418 419 420 421 422 423 424 425 426 427 428 429

dsExpr (HsMultiIf res_ty alts)
  | 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
430
                               (text "multi-way if")
431

Austin Seipp's avatar
Austin Seipp committed
432
{-
433 434
\noindent
\underline{\bf Various data construction things}
Austin Seipp's avatar
Austin Seipp committed
435 436 437 438
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-}

dsExpr (ExplicitList elt_ty wit xs)
439
  = dsExplicitList elt_ty wit xs
440

441 442
-- We desugar [:x1, ..., xn:] as
--   singletonP x1 +:+ ... +:+ singletonP xn
chak's avatar
chak committed
443
--
444
dsExpr (ExplicitPArr ty []) = do
445
    emptyP <- dsDPHBuiltin emptyPVar
446
    return (Var emptyP `App` Type ty)
447
dsExpr (ExplicitPArr ty xs) = do
448 449
    singletonP <- dsDPHBuiltin singletonPVar
    appP       <- dsDPHBuiltin appPVar
Richard Eisenberg's avatar
Richard Eisenberg committed
450
    xs'        <- mapM dsLExprNoLP xs
451 452 453
    let unary  fn x   = mkApps (Var fn) [Type ty, x]
        binary fn x y = mkApps (Var fn) [Type ty, x, y]

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

456 457 458
dsExpr (ArithSeq expr witness seq)
  = case witness of
     Nothing -> dsArithSeq expr seq
459 460
     Just fl -> do { newArithSeq <- dsArithSeq expr seq
                   ; dsSyntaxExpr fl [newArithSeq] }
461 462

dsExpr (PArrSeq expr (FromTo from to))
Richard Eisenberg's avatar
Richard Eisenberg committed
463
  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to]
464 465

dsExpr (PArrSeq expr (FromThenTo from thn to))
Richard Eisenberg's avatar
Richard Eisenberg committed
466
  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to]
chak's avatar
chak committed
467

468
dsExpr (PArrSeq _ _)
chak's avatar
chak committed
469 470 471
  = panic "DsExpr.dsExpr: Infinite parallel array!"
    -- the parser shouldn't have generated it and the renamer and typechecker
    -- shouldn't have let it through
472

Facundo Domínguez's avatar
Facundo Domínguez committed
473
{-
474 475 476
Static Pointers
~~~~~~~~~~~~~~~

477 478
See Note [Grand plan for static forms] in StaticPtrTable for an overview.

Facundo Domínguez's avatar
Facundo Domínguez committed
479 480
    g = ... static f ...
==>
481
    g = ... makeStatic loc f ...
Facundo Domínguez's avatar
Facundo Domínguez committed
482 483
-}

484
dsExpr (HsStatic _ expr@(L loc _)) = do
Richard Eisenberg's avatar
Richard Eisenberg committed
485
    expr_ds <- dsLExprNoLP expr
Facundo Domínguez's avatar
Facundo Domínguez committed
486
    let ty = exprType expr_ds
487
    makeStaticId <- dsLookupGlobalId makeStaticName
Facundo Domínguez's avatar
Facundo Domínguez committed
488 489 490 491 492 493 494

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

500 501
    putSrcSpanDs loc $ return $
      mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
502

Austin Seipp's avatar
Austin Seipp committed
503
{-
504 505
\noindent
\underline{\bf Record construction and update}
Austin Seipp's avatar
Austin Seipp committed
506
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
507
For record construction we do this (assuming T has three arguments)
508
\begin{verbatim}
509
        T { op2 = e }
510
==>
Austin Seipp's avatar
Austin Seipp committed
511
        let err = /\a -> recConErr a
512
        T (recConErr t1 "M.hs/230/op1")
Austin Seipp's avatar
Austin Seipp committed
513
          e
514
          (recConErr t1 "M.hs/230/op3")
515
\end{verbatim}
516
@recConErr@ then converts its argument string into a proper message
517
before printing it as
518
\begin{verbatim}
519
        M.hs, line 230: missing field op1 was evaluated
520
\end{verbatim}
521

522 523
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
524
-}
525

526 527 528 529 530 531 532
dsExpr (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds
                  , rcon_con_like = con_like })
  = do { con_expr' <- dsExpr con_expr
       ; let
             (arg_tys, _) = tcSplitFunTys (exprType con_expr')
             -- A newtype in the corner should be opaque;
             -- hence TcType.tcSplitFunTys
533

534 535 536
             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
537
                                 dsLExprNoLP rhs
538 539
                   []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
             unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
540

541
             labels = conLikeFieldLabels con_like
Austin Seipp's avatar
Austin Seipp committed
542

543 544 545
       ; 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
546

547
       ; return (mkCoreApps con_expr' con_args) }
548

Austin Seipp's avatar
Austin Seipp committed
549
{-
550
Record update is a little harder. Suppose we have the decl:
551
\begin{verbatim}
552 553 554
        data T = T1 {op1, op2, op3 :: Int}
               | T2 {op4, op2 :: Int}
               | T3
555
\end{verbatim}
556
Then we translate as follows:
557
\begin{verbatim}
558
        r { op2 = e }
559
===>
560 561 562 563
        let op2 = e in
        case r of
          T1 op1 _ op3 -> T1 op1 op2 op3
          T2 op4 _     -> T2 op4 op2
564
          other        -> recUpdError "M.hs/230"
565 566
\end{verbatim}
It's important that we use the constructor Ids for @T1@, @T2@ etc on the
567
RHSs, and do not generate a Core constructor application directly, because the constructor
568 569 570
might do some argument-evaluation first; and may have to throw away some
dictionaries.

571 572
Note [Update for GADTs]
~~~~~~~~~~~~~~~~~~~~~~~
Austin Seipp's avatar
Austin Seipp committed
573
Consider
574
   data T a b where
575
     T1 :: { f1 :: a } -> T a Int
576

Austin Seipp's avatar
Austin Seipp committed
577
Then the wrapper function for T1 has type
578 579 580 581
   $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.
582

Austin Seipp's avatar
Austin Seipp committed
583
-}
584

585 586 587 588
dsExpr 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 } )
589
  | null fields
590
  = dsLExpr record_expr
591
  | otherwise
592
  = ASSERT2( notNull cons_to_upd, ppr expr )
593

594 595 596 597 598 599 600 601
    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
602
        -- constructor arguments.
603
        ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
604
        ; ([discrim_var], matching_code)
605 606 607 608 609
                <- 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
610 611 612

        ; return (add_field_binds field_binds' $
                  bindNonRec discrim_var record_expr' matching_code) }
613
  where
Adam Gundry's avatar
Adam Gundry committed
614
    ds_field :: LHsRecUpdField Id -> DsM (Name, Id, CoreExpr)
615
      -- Clone the Id in the HsRecField, because its Name is that
Adam Gundry's avatar
Adam Gundry committed
616
      -- of the record selector, and we must not make that a local binder
617 618
      -- else we shadow other uses of the record selector
      -- Hence 'lcl_id'.  Cf Trac #2735
619
    ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
Adam Gundry's avatar
Adam Gundry committed
620
                                  ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
621 622
                                  ; lcl_id <- newSysLocalDs (idType fld_id)
                                  ; return (idName fld_id, lcl_id, rhs) }
623 624

    add_field_binds [] expr = expr
625
    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
626

Austin Seipp's avatar
Austin Seipp committed
627
        -- Awkwardly, for families, the match goes
628
        -- from instance type to family type
Matthew Pickering's avatar
Matthew Pickering committed
629 630 631 632 633 634
    (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 ->
635
          ( patSynInstResTy pat_syn in_inst_tys
Matthew Pickering's avatar
Matthew Pickering committed
636
          , patSynInstResTy pat_syn out_inst_tys)
637
    mk_alt upd_fld_env con
Austin Seipp's avatar
Austin Seipp committed
638
      = do { let (univ_tvs, ex_tvs, eq_spec,
Matthew Pickering's avatar
Matthew Pickering committed
639
                  prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
640
                 subst = zipTvSubst univ_tvs in_inst_tys
641 642 643

                -- 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
644
           ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta)
645
           ; arg_ids    <- newSysLocalsDs (substTysUnchecked subst arg_tys)
Matthew Pickering's avatar
Matthew Pickering committed
646 647 648
           ; let field_labels = conLikeFieldLabels con
                 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
                                         field_labels arg_ids
Adam Gundry's avatar
Adam Gundry committed
649 650
                 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
651 652

                 inst_con = noLoc $ HsWrap wrap (HsConLikeOut con)
653
                        -- Reconstruct with the WrapId so that unpacking happens
Matthew Pickering's avatar
Matthew Pickering committed
654
                 -- The order here is because of the order in `TcPatSyn`.
655 656
                 wrap = mkWpEvVarApps theta_vars                                <.>
                        dict_req_wrap                                           <.>
657 658 659 660
                        mkWpTyApps    (mkTyVarTys ex_tvs)                       <.>
                        mkWpTyApps    [ ty
                                      | (tv, ty) <- univ_tvs `zip` out_inst_tys
                                      , not (tv `elemVarEnv` wrap_subst) ]
661 662 663 664
                 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
665 666 667 668 669 670 671 672 673 674 675 676 677 678 679
                 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
680
                             else mkLHsWrap (mkWpCastN wrap_co) rhs
Matthew Pickering's avatar
Matthew Pickering committed
681 682 683 684 685
                    -- eq_spec is always null for a PatSynCon
                    PatSynCon _ -> rhs

                 wrap_subst =
                  mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
686 687
                           | (spec, eq_var) <- eq_spec `zip` eqs_vars
                           , let tv = eqSpecTyVar spec ]
Matthew Pickering's avatar
Matthew Pickering committed
688 689

                 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
690

Matthew Pickering's avatar
Matthew Pickering committed
691
                 pat = noLoc $ ConPatOut { pat_con = noLoc con
Gergő Érdi's avatar
Gergő Érdi committed
692
                                         , pat_tvs = ex_tvs
693 694 695
                                         , pat_dicts = eqs_vars ++ theta_vars
                                         , pat_binds = emptyTcEvBinds
                                         , pat_args = PrefixCon $ map nlVarPat arg_ids
696
                                         , pat_arg_tys = in_inst_tys
Matthew Pickering's avatar
Matthew Pickering committed
697
                                         , pat_wrap = req_wrap }
698
           ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
699

Austin Seipp's avatar
Austin Seipp committed
700
-- Here is where we desugar the Template Haskell brackets and escapes
701 702 703

-- Template Haskell stuff

gmainland's avatar
gmainland committed
704
dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"
705
dsExpr (HsTcBracketOut x ps) = dsBracket x ps
706
dsExpr (HsSpliceE s)  = pprPanic "dsExpr:splice" (ppr s)
707

708
-- Arrow notation extension
709
dsExpr (HsProc pat cmd) = dsProcExpr pat cmd
710

Austin Seipp's avatar
Austin Seipp committed
711
-- Hpc Support
andy@galois.com's avatar
andy@galois.com committed
712

713
dsExpr (HsTick tickish e) = do
andy@galois.com's avatar
andy@galois.com committed
714
  e' <- dsLExpr e
715
  return (Tick tickish e')
andy@galois.com's avatar
andy@galois.com committed
716 717 718 719 720 721 722 723 724 725

-- 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.

dsExpr (HsBinTick ixT ixF e) = do
  e2 <- dsLExpr e
726
  do { ASSERT(exprType e2 `eqType` boolTy)
andy@galois.com's avatar
andy@galois.com committed
727 728
       mkBinaryTickBox ixT ixF e2
     }
729

730
dsExpr (HsTickPragma _ _ _ expr) = do
Alan Zimmerman's avatar
Alan Zimmerman committed
731 732 733 734 735
  dflags <- getDynFlags
  if gopt Opt_Hpc dflags
    then panic "dsExpr:HsTickPragma"
    else dsLExpr expr

736
-- HsSyn constructs that just shouldn't be here:
737 738 739 740 741 742 743 744
dsExpr (ExprWithTySig {})  = panic "dsExpr:ExprWithTySig"
dsExpr (HsBracket     {})  = panic "dsExpr:HsBracket"
dsExpr (HsArrApp      {})  = panic "dsExpr:HsArrApp"
dsExpr (HsArrForm     {})  = panic "dsExpr:HsArrForm"
dsExpr (EWildPat      {})  = panic "dsExpr:EWildPat"
dsExpr (EAsPat        {})  = panic "dsExpr:EAsPat"
dsExpr (EViewPat      {})  = panic "dsExpr:EViewPat"
dsExpr (ELazyPat      {})  = panic "dsExpr:ELazyPat"
745
dsExpr (HsAppType     {})  = panic "dsExpr:HsAppType" -- removed by typechecker
746
dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
747
dsExpr (HsRecFld      {})  = panic "dsExpr:HsRecFld"
748

749 750 751 752 753 754
------------------------------
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
755 756 757 758
  = 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
Richard Eisenberg's avatar
Richard Eisenberg committed
759
       ; zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
760
       ; return (core_res_wrap (mkApps fun wrapped_args)) }
Richard Eisenberg's avatar
Richard Eisenberg committed
761 762
  where
    mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
763

764
findField :: [LHsRecField Id arg] -> Name -> [arg]
Adam Gundry's avatar
Adam Gundry committed