{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


Desugaring expressions.
-}

{-# LANGUAGE CPP, MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

module GHC.HsToCore.Expr
   ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
   , dsValBinds, dsLit, dsSyntaxExpr
   , dsHandleMonadicFailure
   )
where

#include "HsVersions.h"

import GHC.Prelude

import GHC.HsToCore.Match
import GHC.HsToCore.Match.Literal
import GHC.HsToCore.Binds
import GHC.HsToCore.GuardedRHSs
import GHC.HsToCore.ListComp
import GHC.HsToCore.Utils
import GHC.HsToCore.Arrows
import GHC.HsToCore.Monad
import GHC.HsToCore.PmCheck ( addTyCsDs, checkGuardMatches )
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Core.FamInstEnv( topNormaliseType )
import GHC.HsToCore.Quote
import GHC.Hs

-- NB: The desugarer, which straddles the source and Core worlds, sometimes
--     needs to see source types
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
import GHC.Core.Type
import GHC.Core
import GHC.Core.Utils
import GHC.Core.Make

import GHC.Driver.Session
import GHC.Types.CostCentre
import GHC.Types.Id
import GHC.Types.Id.Make
import GHC.Unit.Module
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.TyCo.Ppr( pprWithTYPE )
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Types.Basic
import GHC.Data.Maybe
import GHC.Types.Var.Env
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Data.Bag
import GHC.Utils.Outputable as Outputable
import GHC.Core.PatSyn

import Control.Monad
import Data.List.NonEmpty ( nonEmpty )

{-
************************************************************************
*                                                                      *
                dsLocalBinds, dsValBinds
*                                                                      *
************************************************************************
-}

dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds (L SrcSpan
_   (EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
_))  CoreExpr
body = CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return CoreExpr
body
dsLocalBinds (L SrcSpan
loc (HsValBinds XHsValBinds GhcTc GhcTc
_ HsValBindsLR GhcTc GhcTc
binds)) CoreExpr
body = SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
                                                 HsValBindsLR GhcTc GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds HsValBindsLR GhcTc GhcTc
binds CoreExpr
body
dsLocalBinds (L SrcSpan
_ (HsIPBinds XHsIPBinds GhcTc GhcTc
_ HsIPBinds GhcTc
binds))    CoreExpr
body = HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds  HsIPBinds GhcTc
binds CoreExpr
body

-------------------------
-- caller sets location
dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds :: HsValBindsLR GhcTc GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds (XValBindsLR (NValBinds [(RecFlag, LHsBinds GhcTc)]
binds [LSig GhcRn]
_)) CoreExpr
body
  = ((RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr)
-> CoreExpr -> [(RecFlag, LHsBinds GhcTc)] -> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
foldrM (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
ds_val_bind CoreExpr
body [(RecFlag, LHsBinds GhcTc)]
binds
dsValBinds (ValBinds {})       CoreExpr
_    = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsValBinds ValBindsIn"

-------------------------
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds (IPBinds XIPBinds GhcTc
ev_binds [LIPBind GhcTc]
ip_binds) CoreExpr
body
  = do  { [CoreBind]
ds_binds <- TcEvBinds -> DsM [CoreBind]
dsTcEvBinds XIPBinds GhcTc
TcEvBinds
ev_binds
        ; let inner :: CoreExpr
inner = [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_binds CoreExpr
body
                -- The dict bindings may not be in
                -- dependency order; hence Rec
        ; (LIPBind GhcTc -> CoreExpr -> DsM CoreExpr)
-> CoreExpr -> [LIPBind GhcTc] -> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
foldrM LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
forall {l}. GenLocated l (IPBind GhcTc) -> CoreExpr -> DsM CoreExpr
ds_ip_bind CoreExpr
inner [LIPBind GhcTc]
ip_binds }
  where
    ds_ip_bind :: GenLocated l (IPBind GhcTc) -> CoreExpr -> DsM CoreExpr
ds_ip_bind (L l
_ (IPBind XCIPBind GhcTc
_ ~(Right IdP GhcTc
n) LHsExpr GhcTc
e)) CoreExpr
body
      = do CoreExpr
e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
           CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
IdP GhcTc
n CoreExpr
e') CoreExpr
body)

-------------------------
-- caller sets location
ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
-- Special case for bindings which bind unlifted variables
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
-- Silently ignore INLINE and SPECIALISE pragmas...
ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
ds_val_bind (RecFlag
NonRecursive, LHsBinds GhcTc
hsbinds) CoreExpr
body
  | [L SrcSpan
loc HsBind GhcTc
bind] <- LHsBinds GhcTc -> [LHsBindLR GhcTc GhcTc]
forall a. Bag a -> [a]
bagToList LHsBinds GhcTc
hsbinds
        -- 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.)
  , HsBind GhcTc -> Bool
isUnliftedHsBind HsBind GhcTc
bind
  = SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
     -- see Note [Strict binds checks] in GHC.HsToCore.Binds
    if HsBind GhcTc -> Bool
forall {idL} {idR}. HsBindLR idL idR -> Bool
is_polymorphic HsBind GhcTc
bind
    then SDoc -> DsM CoreExpr
errDsCoreExpr (HsBind GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall (pl :: Pass) (pr :: Pass).
(OutputableBndrId pl, OutputableBndrId pr) =>
Outputable (HsBindLR (GhcPass pl) (GhcPass pr))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
poly_bind_err HsBind GhcTc
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.  #6078.

    else do { Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
when (HsBind GhcTc -> Bool
forall (p :: Pass). HsBind (GhcPass p) -> Bool
looksLazyPatBind HsBind GhcTc
bind) (IOEnv (Env DsGblEnv DsLclEnv) ()
 -> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
              WarningFlag -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnIfSetDs WarningFlag
Opt_WarnUnbangedStrictPatterns (HsBind GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall (pl :: Pass) (pr :: Pass).
(OutputableBndrId pl, OutputableBndrId pr) =>
Outputable (HsBindLR (GhcPass pl) (GhcPass pr))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
unlifted_must_be_bang HsBind GhcTc
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


            ; HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind HsBind GhcTc
bind CoreExpr
body }
  where
    is_polymorphic :: HsBindLR idL idR -> Bool
is_polymorphic (AbsBinds { abs_tvs :: forall idL idR. HsBindLR idL idR -> [Id]
abs_tvs = [Id]
tvs, abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [Id]
abs_ev_vars = [Id]
evs })
                     = Bool -> Bool
not ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [Id]
tvs Bool -> Bool -> Bool
&& [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [Id]
evs)
    is_polymorphic HsBindLR idL idR
_ = Bool
False

    unlifted_must_be_bang :: a -> SDoc
unlifted_must_be_bang a
bind
      = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Pattern bindings containing unlifted types should use" SDoc -> SDoc -> SDoc
$$
              String -> SDoc
text String
"an outermost bang pattern:")
           Int
2 (a -> SDoc
forall {a}. Outputable a => a -> SDoc
Evidence bound by a type signature of the constraint type Outputable a
ppr a
bind)

    poly_bind_err :: a -> SDoc
poly_bind_err a
bind
      = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"You can't mix polymorphic and unlifted bindings:")
           Int
2 (a -> SDoc
forall {a}. Outputable a => a -> SDoc
Evidence bound by a type signature of the constraint type Outputable a
ppr a
bind) SDoc -> SDoc -> SDoc
$$
        String -> SDoc
text String
"Probable fix: add a type signature"

ds_val_bind (RecFlag
is_rec, LHsBinds GhcTc
binds) CoreExpr
_body
  | (LHsBindLR GhcTc GhcTc -> Bool) -> LHsBinds GhcTc -> Bool
forall a. (a -> Bool) -> Bag a -> Bool
anyBag (HsBind GhcTc -> Bool
isUnliftedHsBind (HsBind GhcTc -> Bool)
-> (LHsBindLR GhcTc GhcTc -> HsBind GhcTc)
-> LHsBindLR GhcTc GhcTc
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsBindLR GhcTc GhcTc -> HsBind GhcTc
forall l e. GenLocated l e -> e
unLoc) LHsBinds GhcTc
binds  -- see Note [Strict binds checks] in GHC.HsToCore.Binds
  = ASSERT( isRec is_rec )
    SDoc -> DsM CoreExpr
errDsCoreExpr (SDoc -> DsM CoreExpr) -> SDoc -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Recursive bindings for unlifted types aren't allowed:")
       Int
2 ([SDoc] -> SDoc
vcat ((LHsBindLR GhcTc GhcTc -> SDoc)
-> [LHsBindLR GhcTc GhcTc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LHsBindLR GhcTc GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (pl :: Pass) (pr :: Pass).
(OutputableBndrId pl, OutputableBndrId pr) =>
Outputable (HsBindLR (GhcPass pl) (GhcPass pr))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr (LHsBinds GhcTc -> [LHsBindLR GhcTc GhcTc]
forall a. Bag a -> [a]
bagToList LHsBinds GhcTc
binds)))

-- Ordinary case for bindings; none should be unlifted
ds_val_bind (RecFlag
is_rec, LHsBinds GhcTc
binds) CoreExpr
body
  = do  { MASSERT( isRec is_rec || isSingletonBag binds )
               -- we should never produce a non-recursive list of multiple binds

        ; ([Id]
force_vars,[(Id, CoreExpr)]
prs) <- LHsBinds GhcTc -> DsM ([Id], [(Id, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
        ; let body' :: CoreExpr
body' = (Id -> CoreExpr -> CoreExpr) -> CoreExpr -> [Id] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
External instance of the constraint type Foldable []
foldr Id -> CoreExpr -> CoreExpr
seqVar CoreExpr
body [Id]
force_vars
        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
          case [(Id, CoreExpr)]
prs of
            [] -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return CoreExpr
body
            [(Id, CoreExpr)]
_  -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let ([(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CoreExpr)]
prs) CoreExpr
body') }
        -- Use a Rec regardless of is_rec.
        -- 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 GHC.Tc.Solver.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

------------------
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (AbsBinds { abs_tvs :: forall idL idR. HsBindLR idL idR -> [Id]
abs_tvs = [], abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [Id]
abs_ev_vars = []
               , abs_exports :: forall idL idR. HsBindLR idL idR -> [ABExport idL]
abs_exports = [ABExport GhcTc]
exports
               , abs_ev_binds :: forall idL idR. HsBindLR idL idR -> [TcEvBinds]
abs_ev_binds = [TcEvBinds]
ev_binds
               , abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds = LHsBinds GhcTc
lbinds }) CoreExpr
body
  = do { let body1 :: CoreExpr
body1 = (ABExport GhcTc -> CoreExpr -> CoreExpr)
-> CoreExpr -> [ABExport GhcTc] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
External instance of the constraint type Foldable []
foldr ABExport GhcTc -> CoreExpr -> CoreExpr
forall {p}. (IdP p ~ Id) => ABExport p -> CoreExpr -> CoreExpr
bind_export CoreExpr
body [ABExport GhcTc]
exports
             bind_export :: ABExport p -> CoreExpr -> CoreExpr
bind_export ABExport p
export CoreExpr
b = Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec (ABExport p -> IdP p
forall p. ABExport p -> IdP p
abe_poly ABExport p
export) (Id -> CoreExpr
forall b. Id -> Expr b
Var (ABExport p -> IdP p
forall p. ABExport p -> IdP p
abe_mono ABExport p
export)) CoreExpr
b
       ; CoreExpr
body2 <- (CoreExpr -> LHsBindLR GhcTc GhcTc -> DsM CoreExpr)
-> CoreExpr -> LHsBinds GhcTc -> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable Bag
foldlM (\CoreExpr
body LHsBindLR GhcTc GhcTc
lbind -> HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (LHsBindLR GhcTc GhcTc -> HsBind GhcTc
forall l e. GenLocated l e -> e
unLoc LHsBindLR GhcTc GhcTc
lbind) CoreExpr
body)
                            CoreExpr
body1 LHsBinds GhcTc
lbinds
       ; [CoreBind]
ds_binds <- [TcEvBinds] -> DsM [CoreBind]
dsTcEvBinds_s [TcEvBinds]
ev_binds
       ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ([CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_binds CoreExpr
body2) }

dsUnliftedBind (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = L SrcSpan
l IdP GhcTc
fun
                        , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
matches
                        , fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_ext = XFunBind GhcTc GhcTc
co_fn
                        , fun_tick :: forall idL idR. HsBindLR idL idR -> [Tickish Id]
fun_tick = [Tickish Id]
tick }) CoreExpr
body
               -- Can't be a bang pattern (that looks like a PatBind)
               -- so must be simply unboxed
  = do { ([Id]
args, CoreExpr
rhs) <- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper (LIdP GhcRn -> HsMatchContext GhcRn
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (Name -> GenLocated SrcSpan Name)
-> Name -> GenLocated SrcSpan Name
forall a b. (a -> b) -> a -> b
$ Id -> Name
idName Id
IdP GhcTc
fun))
                                     Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
       ; MASSERT( null args ) -- Functions aren't lifted
       ; MASSERT( isIdHsWrapper co_fn )
       ; let rhs' :: CoreExpr
rhs' = [Tickish Id] -> CoreExpr -> CoreExpr
mkOptTickBox [Tickish Id]
tick CoreExpr
rhs
       ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
IdP GhcTc
fun CoreExpr
rhs' CoreExpr
body) }

dsUnliftedBind (PatBind {pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcTc
pat, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
grhss
                        , pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = NPatBindTc NameSet
_ Type
ty }) CoreExpr
body
  =     -- let C x# y# = rhs in body
        -- ==> case rhs of C x# y# -> body
    do { [Deltas]
rhs_deltas <- HsMatchContext GhcRn -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM [Deltas]
checkGuardMatches HsMatchContext GhcRn
forall p. HsMatchContext p
PatBindGuards GRHSs GhcTc (LHsExpr GhcTc)
grhss
       ; CoreExpr
rhs         <- GRHSs GhcTc (LHsExpr GhcTc)
-> Type -> Maybe (NonEmpty Deltas) -> DsM CoreExpr
dsGuarded GRHSs GhcTc (LHsExpr GhcTc)
grhss Type
ty ([Deltas] -> Maybe (NonEmpty Deltas)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Deltas]
rhs_deltas)
       ; let upat :: Pat GhcTc
upat = Located (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc Located (Pat GhcTc)
LPat GhcTc
pat
             eqn :: EquationInfo
eqn = EqnInfo :: [Pat GhcTc] -> Origin -> MatchResult CoreExpr -> EquationInfo
EqnInfo { eqn_pats :: [Pat GhcTc]
eqn_pats = [Pat GhcTc
upat],
                             eqn_orig :: Origin
eqn_orig = Origin
FromSource,
                             eqn_rhs :: MatchResult CoreExpr
eqn_rhs = CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
body }
       ; Id
var    <- Pat GhcTc -> DsM Id
selectMatchVar Pat GhcTc
upat
       ; CoreExpr
result <- HsMatchContext GhcRn
-> [Id] -> [EquationInfo] -> Type -> DsM CoreExpr
matchEquations HsMatchContext GhcRn
forall p. HsMatchContext p
PatBindRhs [Id
var] [EquationInfo
eqn] (CoreExpr -> Type
exprType CoreExpr
body)
       ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
var CoreExpr
rhs CoreExpr
result) }

dsUnliftedBind HsBind GhcTc
bind CoreExpr
body = String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsLet: unlifted" (HsBind GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall (pl :: Pass) (pr :: Pass).
(OutputableBndrId pl, OutputableBndrId pr) =>
Outputable (HsBindLR (GhcPass pl) (GhcPass pr))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr HsBind GhcTc
bind SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall b. OutputableBndr b => Outputable (Expr b)
External instance of the constraint type OutputableBndr Id
ppr CoreExpr
body)

{-
************************************************************************
*                                                                      *
*              Variables, constructors, literals                       *
*                                                                      *
************************************************************************
-}

dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr

dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (L SrcSpan
loc HsExpr GhcTc
e)
  = SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
    do { CoreExpr
core_expr <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
e
   -- uncomment this check to test the hsExprType function in GHC.Tc.Utils.Zonk
   --    ; MASSERT2( exprType core_expr `eqType` hsExprType e
   --              , ppr e <+> dcolon <+> ppr (hsExprType e) $$
   --                ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )
       ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return CoreExpr
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 GHC.HsToCore.Monad
-- See Note [Levity polymorphism invariants] in GHC.Core
dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP (L SrcSpan
loc HsExpr GhcTc
e)
  = SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
    do { CoreExpr
e' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
e
       ; CoreExpr -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
dsNoLevPolyExpr CoreExpr
e' (String -> SDoc
text String
"In the type of expression:" SDoc -> SDoc -> SDoc
<+> HsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr HsExpr GhcTc
e)
       ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return CoreExpr
e' }

dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsExpr (HsPar XPar GhcTc
_ LHsExpr GhcTc
e)            = LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
dsExpr (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
_)  = LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
dsExpr (HsVar XVar GhcTc
_ (L SrcSpan
_ IdP GhcTc
var))    = Id -> DsM CoreExpr
dsHsVar Id
IdP GhcTc
var
dsExpr (HsUnboundVar {})      = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr: HsUnboundVar" -- Typechecker eliminates them
dsExpr (HsConLikeOut XConLikeOut GhcTc
_ ConLike
con)   = ConLike -> DsM CoreExpr
dsConLike ConLike
con
dsExpr (HsIPVar {})           = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr: HsIPVar"
dsExpr (HsOverLabel{})        = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr: HsOverLabel"

dsExpr (HsLit XLitE GhcTc
_ HsLit GhcTc
lit)
  = do { HsLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedLit HsLit GhcTc
lit
       ; HsLit GhcRn -> DsM CoreExpr
dsLit (HsLit GhcTc -> HsLit GhcRn
forall (p1 :: Pass) (p2 :: Pass).
HsLit (GhcPass p1) -> HsLit (GhcPass p2)
convertLit HsLit GhcTc
lit) }

dsExpr (HsOverLit XOverLitE GhcTc
_ HsOverLit GhcTc
lit)
  = do { HsOverLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedOverLit HsOverLit GhcTc
lit
       ; HsOverLit GhcTc -> DsM CoreExpr
dsOverLit HsOverLit GhcTc
lit }

dsExpr hswrap :: HsExpr GhcTc
hswrap@(XExpr (HsWrap HsWrapper
co_fn HsExpr GhcTc
e))
  = do { CoreExpr
e' <- case HsExpr GhcTc
e of
                 HsVar XVar GhcTc
_ (L SrcSpan
_ IdP GhcTc
var) -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
IdP GhcTc
var
                 HsConLikeOut XConLikeOut GhcTc
_ (RealDataCon DataCon
dc) -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr (DataCon -> Id
dataConWrapId DataCon
dc)
                 XExpr (HsWrap HsWrapper
_ HsExpr GhcTc
_) -> String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsExpr: HsWrap inside HsWrap" (HsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr HsExpr GhcTc
hswrap)
                 HsPar XPar GhcTc
_ LHsExpr GhcTc
_ -> String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsExpr: HsPar inside HsWrap" (HsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr HsExpr GhcTc
hswrap)
                 HsExpr GhcTc
_ -> Origin -> Bag Id -> DsM CoreExpr -> DsM CoreExpr
forall a. Origin -> Bag Id -> DsM a -> DsM a
addTyCsDs Origin
FromSource (HsWrapper -> Bag Id
hsWrapDictBinders HsWrapper
co_fn) (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
                      HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
e
               -- See Note [Detecting forced eta expansion]
       ; CoreExpr -> CoreExpr
wrap' <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
co_fn
       ; DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
       ; let wrapped_e :: CoreExpr
wrapped_e = CoreExpr -> CoreExpr
wrap' CoreExpr
e'
             wrapped_ty :: Type
wrapped_ty = CoreExpr -> Type
exprType CoreExpr
wrapped_e
       ; HsExpr GhcTc -> SDoc -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
checkForcedEtaExpansion HsExpr GhcTc
e (HsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr HsExpr GhcTc
hswrap) Type
wrapped_ty -- See Note [Detecting forced eta expansion]
         -- Pass HsWrap, so that the user can see entire expression with -fprint-typechecker-elaboration
       ; DynFlags -> CoreExpr -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutIdentities DynFlags
dflags CoreExpr
e' Type
wrapped_ty
       ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return CoreExpr
wrapped_e }

dsExpr (NegApp XNegApp GhcTc
_ (L SrcSpan
loc
                    (HsOverLit XOverLitE GhcTc
_ lit :: HsOverLit GhcTc
lit@(OverLit { ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = HsIntegral IntegralLit
i})))
                SyntaxExpr GhcTc
neg_expr)
  = do { CoreExpr
expr' <- SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ do
          { HsOverLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedOverLit
              (HsOverLit GhcTc
lit { ol_val :: OverLitVal
ol_val = IntegralLit -> OverLitVal
HsIntegral (IntegralLit -> IntegralLit
negateIntegralLit IntegralLit
i) })
          ; HsOverLit GhcTc -> DsM CoreExpr
dsOverLit HsOverLit GhcTc
lit }
       ; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
neg_expr [CoreExpr
expr'] }

dsExpr (NegApp XNegApp GhcTc
_ LHsExpr GhcTc
expr SyntaxExpr GhcTc
neg_expr)
  = do { CoreExpr
expr' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
       ; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
neg_expr [CoreExpr
expr'] }

dsExpr (HsLam XLam GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
a_Match)
  = ([Id] -> CoreExpr -> CoreExpr) -> ([Id], CoreExpr) -> CoreExpr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams (([Id], CoreExpr) -> CoreExpr)
-> DsM ([Id], CoreExpr) -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
<$> HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper HsMatchContext GhcRn
forall p. HsMatchContext p
LambdaExpr Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
a_Match

dsExpr (HsLamCase XLamCase GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
matches)
  = do { ([Id
discrim_var], CoreExpr
matching_code) <- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
       ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
discrim_var CoreExpr
matching_code }

dsExpr e :: HsExpr GhcTc
e@(HsApp XApp GhcTc
_ LHsExpr GhcTc
fun LHsExpr GhcTc
arg)
  = do { CoreExpr
fun' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
fun
       ; DsM CoreExpr -> (CoreExpr -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs (LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
arg)
                      (\CoreExpr
arg' -> SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs (String -> SDoc
text String
"HsApp" SDoc -> SDoc -> SDoc
<+> HsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr HsExpr GhcTc
e) CoreExpr
fun' CoreExpr
arg') }

dsExpr (HsAppType XAppTypeE GhcTc
ty LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
_)
  = do { CoreExpr
e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
       ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
e' (Type -> CoreExpr
forall b. Type -> Expr b
Type Type
XAppTypeE GhcTc
ty)) }

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

Operator sections.  At first it looks as if we can convert
\begin{verbatim}
        (expr op)
\end{verbatim}
to
\begin{verbatim}
        \x -> op expr x
\end{verbatim}

But no!  expr might be a redex, and we can lose laziness badly this
way.  Consider
\begin{verbatim}
        map (expr op) xs
\end{verbatim}
for example.  So we convert instead to
\begin{verbatim}
        let y = expr in \x -> op y x
\end{verbatim}
If \tr{expr} is actually just a variable, say, then the simplifier
will sort it out.
-}

dsExpr e :: HsExpr GhcTc
e@(OpApp XOpApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
op LHsExpr GhcTc
e2)
  = -- for the type of y, we need the type of op's 2nd argument
    do { CoreExpr
op' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
op
       ; DsM [CoreExpr] -> ([CoreExpr] -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs ((LHsExpr GhcTc -> DsM CoreExpr)
-> [LHsExpr GhcTc] -> DsM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP [LHsExpr GhcTc
e1, LHsExpr GhcTc
e2])
                      (\[CoreExpr]
exprs' -> SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs (String -> SDoc
text String
"opapp" SDoc -> SDoc -> SDoc
<+> HsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr HsExpr GhcTc
e) CoreExpr
op' [CoreExpr]
exprs') }

dsExpr (SectionL XSectionL GhcTc
_ LHsExpr GhcTc
expr LHsExpr GhcTc
op)       -- Desugar (e !) to ((!) e)
  = do { CoreExpr
op' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
op
       ; DsM CoreExpr -> (CoreExpr -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs (LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
expr)
                      (\CoreExpr
expr' -> SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs (String -> SDoc
text String
"sectionl" SDoc -> SDoc -> SDoc
<+> LHsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr LHsExpr GhcTc
expr) CoreExpr
op' CoreExpr
expr') }

-- dsLExpr (SectionR op expr)   -- \ x -> op x expr
dsExpr e :: HsExpr GhcTc
e@(SectionR XSectionR GhcTc
_ LHsExpr GhcTc
op LHsExpr GhcTc
expr) = do
    CoreExpr
core_op <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
op
    -- for the type of x, we need the type of op's 2nd argument
    let (Type
x_ty:Type
y_ty:[Type]
_, Type
_) = Type -> ([Type], Type)
splitFunTys (CoreExpr -> Type
exprType CoreExpr
core_op)
        -- See comment with SectionL
    CoreExpr
y_core <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
    DsM [Id] -> ([Id] -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs ((Type -> DsM Id) -> [Type] -> DsM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM Type -> DsM Id
newSysLocalDsNoLP [Type
x_ty, Type
y_ty])
                 (\[Id
x_id, Id
y_id] -> Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
y_id CoreExpr
y_core (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                                   Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
x_id (SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs (String -> SDoc
text String
"sectionr" SDoc -> SDoc -> SDoc
<+> HsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr HsExpr GhcTc
e)
                                                          CoreExpr
core_op [Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x_id, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
y_id]))

dsExpr (ExplicitTuple XExplicitTuple GhcTc
_ [LHsTupArg GhcTc]
tup_args Boxity
boxity)
  = do { let go :: ([Id], [CoreExpr])
-> GenLocated l (HsTupArg GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
go ([Id]
lam_vars, [CoreExpr]
args) (L l
_ (Missing XMissing GhcTc
ty))
                    -- For every missing expression, we need
                    -- another lambda in the desugaring.
               = do { Id
lam_var <- Type -> DsM Id
newSysLocalDsNoLP Type
XMissing GhcTc
ty
                    ; ([Id], [CoreExpr])
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Id
lam_var Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
lam_vars, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
lam_var CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args) }
             go ([Id]
lam_vars, [CoreExpr]
args) (L l
_ (Present XPresent GhcTc
_ LHsExpr GhcTc
expr))
                    -- Expressions that are present don't generate
                    -- lambdas, just arguments.
               = do { CoreExpr
core_expr <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
expr
                    ; ([Id], [CoreExpr])
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ([Id]
lam_vars, CoreExpr
core_expr CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args) }

       ; IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
-> (([Id], [CoreExpr]) -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs ((([Id], [CoreExpr])
 -> LHsTupArg GhcTc
 -> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr]))
-> ([Id], [CoreExpr])
-> [LHsTupArg GhcTc]
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
foldM ([Id], [CoreExpr])
-> LHsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
forall {l}.
([Id], [CoreExpr])
-> GenLocated l (HsTupArg GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
go ([], []) ([LHsTupArg GhcTc] -> [LHsTupArg GhcTc]
forall a. [a] -> [a]
reverse [LHsTupArg GhcTc]
tup_args))
                -- The reverse is because foldM goes left-to-right
                      (\([Id]
lam_vars, [CoreExpr]
args) -> [Id] -> CoreExpr -> CoreExpr
mkCoreLams [Id]
lam_vars (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                                            Boxity -> [CoreExpr] -> CoreExpr
mkCoreTupBoxity Boxity
boxity [CoreExpr]
args) }
                        -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make

dsExpr (ExplicitSum XExplicitSum GhcTc
types Int
alt Int
arity LHsExpr GhcTc
expr)
  = do { DsM CoreExpr -> (CoreExpr -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs (LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
expr)
                      (\CoreExpr
core_expr -> DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Int -> Int -> DataCon
sumDataCon Int
alt Int
arity)
                                     ((Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> CoreExpr
forall b. Type -> Expr b
Type (Type -> CoreExpr) -> (Type -> Type) -> Type -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Type
Type -> Type
External instance of the constraint type HasDebugCallStack
getRuntimeRep) [Type]
XExplicitSum GhcTc
types [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++
                                      (Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type [Type]
XExplicitSum GhcTc
types [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++
                                      [CoreExpr
core_expr]) ) }

dsExpr (HsPragE XPragE GhcTc
_ HsPragE GhcTc
prag LHsExpr GhcTc
expr) =
  HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
ds_prag_expr HsPragE GhcTc
prag LHsExpr GhcTc
expr

dsExpr (HsCase XCase GhcTc
_ LHsExpr GhcTc
discrim MatchGroup GhcTc (LHsExpr GhcTc)
matches)
  = do { CoreExpr
core_discrim <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
discrim
       ; ([Id
discrim_var], CoreExpr
matching_code) <- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt (LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
forall a. a -> Maybe a
Just LHsExpr GhcTc
discrim) MatchGroup GhcTc (LHsExpr GhcTc)
matches
       ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
discrim_var CoreExpr
core_discrim CoreExpr
matching_code) }

-- Pepe: The binds are in scope in the body but NOT in the binding group
--       This is to avoid silliness in breakpoints
dsExpr (HsLet XLet GhcTc
_ LHsLocalBinds GhcTc
binds LHsExpr GhcTc
body) = do
    CoreExpr
body' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
body
    LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds LHsLocalBinds GhcTc
binds CoreExpr
body'

-- 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.
--
dsExpr (HsDo XDo GhcTc
res_ty HsStmtContext GhcRn
ListComp (L SrcSpan
_ [ExprLStmt GhcTc]
stmts)) = [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
dsListComp [ExprLStmt GhcTc]
stmts Type
XDo GhcTc
res_ty
dsExpr (HsDo XDo GhcTc
_ HsStmtContext GhcRn
DoExpr        (L SrcSpan
_ [ExprLStmt GhcTc]
stmts)) = [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo [ExprLStmt GhcTc]
stmts
dsExpr (HsDo XDo GhcTc
_ HsStmtContext GhcRn
GhciStmtCtxt  (L SrcSpan
_ [ExprLStmt GhcTc]
stmts)) = [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo [ExprLStmt GhcTc]
stmts
dsExpr (HsDo XDo GhcTc
_ HsStmtContext GhcRn
MDoExpr       (L SrcSpan
_ [ExprLStmt GhcTc]
stmts)) = [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo [ExprLStmt GhcTc]
stmts
dsExpr (HsDo XDo GhcTc
_ HsStmtContext GhcRn
MonadComp     (L SrcSpan
_ [ExprLStmt GhcTc]
stmts)) = [ExprLStmt GhcTc] -> DsM CoreExpr
dsMonadComp [ExprLStmt GhcTc]
stmts

dsExpr (HsIf XIf GhcTc
_ SyntaxExpr GhcTc
fun LHsExpr GhcTc
guard_expr LHsExpr GhcTc
then_expr LHsExpr GhcTc
else_expr)
  = do { CoreExpr
pred <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
guard_expr
       ; CoreExpr
b1 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
then_expr
       ; CoreExpr
b2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
else_expr
       ; case SyntaxExpr GhcTc
fun of  -- See Note [Rebindable if] in Hs.Expr
           (SyntaxExprTc {}) -> SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
fun [CoreExpr
pred, CoreExpr
b1, CoreExpr
b2]
           SyntaxExpr GhcTc
SyntaxExprTc
NoSyntaxExprTc    -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse CoreExpr
pred CoreExpr
b1 CoreExpr
b2 }

dsExpr (HsMultiIf XMultiIf GhcTc
res_ty [LGRHS GhcTc (LHsExpr GhcTc)]
alts)
  | [LGRHS GhcTc (LHsExpr GhcTc)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [LGRHS GhcTc (LHsExpr GhcTc)]
alts
  = DsM CoreExpr
mkErrorExpr

  | Bool
otherwise
  = do { let grhss :: GRHSs GhcTc (LHsExpr GhcTc)
grhss = XCGRHSs GhcTc (LHsExpr GhcTc)
-> [LGRHS GhcTc (LHsExpr GhcTc)]
-> LHsLocalBinds GhcTc
-> GRHSs GhcTc (LHsExpr GhcTc)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTc (LHsExpr GhcTc)
NoExtField
noExtField [LGRHS GhcTc (LHsExpr GhcTc)]
alts (HsLocalBindsLR GhcTc GhcTc -> LHsLocalBinds GhcTc
forall e. e -> Located e
noLoc HsLocalBindsLR GhcTc GhcTc
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)
       ; [Deltas]
rhss_deltas  <- HsMatchContext GhcRn -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM [Deltas]
checkGuardMatches HsMatchContext GhcRn
forall p. HsMatchContext p
IfAlt GRHSs GhcTc (LHsExpr GhcTc)
grhss
       ; MatchResult CoreExpr
match_result <- HsMatchContext GhcRn
-> GRHSs GhcTc (LHsExpr GhcTc)
-> Type
-> Maybe (NonEmpty Deltas)
-> DsM (MatchResult CoreExpr)
dsGRHSs HsMatchContext GhcRn
forall p. HsMatchContext p
IfAlt GRHSs GhcTc (LHsExpr GhcTc)
grhss Type
XMultiIf GhcTc
res_ty ([Deltas] -> Maybe (NonEmpty Deltas)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Deltas]
rhss_deltas)
       ; CoreExpr
error_expr   <- DsM CoreExpr
mkErrorExpr
       ; MatchResult CoreExpr -> CoreExpr -> DsM CoreExpr
extractMatchResult MatchResult CoreExpr
match_result CoreExpr
error_expr }
  where
    mkErrorExpr :: DsM CoreExpr
mkErrorExpr = Id -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
nON_EXHAUSTIVE_GUARDS_ERROR_ID Type
XMultiIf GhcTc
res_ty
                               (String -> SDoc
text String
"multi-way if")

{-
\noindent
\underline{\bf Various data construction things}
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-}

dsExpr (ExplicitList XExplicitList GhcTc
elt_ty Maybe (SyntaxExpr GhcTc)
wit [LHsExpr GhcTc]
xs)
  = Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> DsM CoreExpr
dsExplicitList Type
XExplicitList GhcTc
elt_ty Maybe (SyntaxExpr GhcTc)
wit [LHsExpr GhcTc]
xs

dsExpr (ArithSeq XArithSeq GhcTc
expr Maybe (SyntaxExpr GhcTc)
witness ArithSeqInfo GhcTc
seq)
  = case Maybe (SyntaxExpr GhcTc)
witness of
     Maybe (SyntaxExpr GhcTc)
Nothing -> HsExpr GhcTc -> ArithSeqInfo GhcTc -> DsM CoreExpr
dsArithSeq XArithSeq GhcTc
HsExpr GhcTc
expr ArithSeqInfo GhcTc
seq
     Just SyntaxExpr GhcTc
fl -> do { CoreExpr
newArithSeq <- HsExpr GhcTc -> ArithSeqInfo GhcTc -> DsM CoreExpr
dsArithSeq XArithSeq GhcTc
HsExpr GhcTc
expr ArithSeqInfo GhcTc
seq
                   ; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
fl [CoreExpr
newArithSeq] }

{-
Static Pointers
~~~~~~~~~~~~~~~

See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.

    g = ... static f ...
==>
    g = ... makeStatic loc f ...
-}

dsExpr (HsStatic XStatic GhcTc
_ expr :: LHsExpr GhcTc
expr@(L SrcSpan
loc HsExpr GhcTc
_)) = do
    CoreExpr
expr_ds <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
expr
    let ty :: Type
ty = CoreExpr -> Type
exprType CoreExpr
expr_ds
    Id
makeStaticId <- Name -> DsM Id
dsLookupGlobalId Name
makeStaticName

    DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    let (Int
line, Int
col) = case SrcSpan
loc of
           RealSrcSpan RealSrcSpan
r Maybe BufSpan
_ ->
                            ( RealSrcLoc -> Int
srcLocLine (RealSrcLoc -> Int) -> RealSrcLoc -> Int
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
r
                            , RealSrcLoc -> Int
srcLocCol  (RealSrcLoc -> Int) -> RealSrcLoc -> Int
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
r
                            )
           SrcSpan
_             -> (Int
0, Int
0)
        srcLoc :: CoreExpr
srcLoc = DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Boxity -> Int -> DataCon
tupleDataCon Boxity
Boxed Int
2)
                     [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy              , Type -> CoreExpr
forall b. Type -> Expr b
Type Type
intTy
                     , Platform -> Int -> CoreExpr
mkIntExprInt Platform
platform Int
line, Platform -> Int -> CoreExpr
mkIntExprInt Platform
platform Int
col
                     ]

    SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
      CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
makeStaticId) [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty, CoreExpr
srcLoc, CoreExpr
expr_ds ]

{-
\noindent
\underline{\bf Record construction and update}
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For record construction we do this (assuming T has three arguments)
\begin{verbatim}
        T { op2 = e }
==>
        let err = /\a -> recConErr a
        T (recConErr t1 "M.hs/230/op1")
          e
          (recConErr t1 "M.hs/230/op3")
\end{verbatim}
@recConErr@ then converts its argument string into a proper message
before printing it as
\begin{verbatim}
        M.hs, line 230: missing field op1 was evaluated
\end{verbatim}

We also handle @C{}@ as valid construction syntax for an unlabelled
constructor @C@, setting all of @C@'s fields to bottom.
-}

dsExpr (RecordCon { rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcTc
rbinds
                  , rcon_ext :: forall p. HsExpr p -> XRecordCon p
rcon_ext = RecordConTc { rcon_con_expr :: RecordConTc -> HsExpr GhcTc
rcon_con_expr = HsExpr GhcTc
con_expr
                                           , rcon_con_like :: RecordConTc -> ConLike
rcon_con_like = ConLike
con_like }})
  = do { CoreExpr
con_expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
con_expr
       ; let
             ([Type]
arg_tys, Type
_) = Type -> ([Type], Type)
tcSplitFunTys (CoreExpr -> Type
exprType CoreExpr
con_expr')
             -- A newtype in the corner should be opaque;
             -- hence TcType.tcSplitFunTys

             mk_arg :: (Type, FieldLbl Name) -> DsM CoreExpr
mk_arg (Type
arg_ty, FieldLbl Name
fl)
               = case [LHsRecField GhcTc (LHsExpr GhcTc)] -> Name -> [LHsExpr GhcTc]
forall arg. [LHsRecField GhcTc arg] -> Name -> [arg]
findField (HsRecordBinds GhcTc -> [LHsRecField GhcTc (LHsExpr GhcTc)]
forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds HsRecordBinds GhcTc
rbinds) (FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector FieldLbl Name
fl) of
                   (LHsExpr GhcTc
rhs:[LHsExpr GhcTc]
rhss) -> ASSERT( null rhss )
                                 LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
rhs
                   []         -> Id -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
rEC_CON_ERROR_ID Type
arg_ty (FieldLabelString -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type Outputable FieldLabelString
ppr (FieldLbl Name -> FieldLabelString
forall a. FieldLbl a -> FieldLabelString
flLabel FieldLbl Name
fl))
             unlabelled_bottom :: Type -> DsM CoreExpr
unlabelled_bottom Type
arg_ty = Id -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
rEC_CON_ERROR_ID Type
arg_ty SDoc
Outputable.empty

             labels :: [FieldLbl Name]
labels = ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con_like

       ; [CoreExpr]
con_args <- if [FieldLbl Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [FieldLbl Name]
labels
                     then (Type -> DsM CoreExpr) -> [Type] -> DsM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM Type -> DsM CoreExpr
unlabelled_bottom [Type]
arg_tys
                     else ((Type, FieldLbl Name) -> DsM CoreExpr)
-> [(Type, FieldLbl Name)] -> DsM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM (Type, FieldLbl Name) -> DsM CoreExpr
mk_arg (String -> [Type] -> [FieldLbl Name] -> [(Type, FieldLbl Name)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"dsExpr:RecordCon" [Type]
arg_tys [FieldLbl Name]
labels)

       ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps CoreExpr
con_expr' [CoreExpr]
con_args) }

{-
Record update is a little harder. Suppose we have the decl:
\begin{verbatim}
        data T = T1 {op1, op2, op3 :: Int}
               | T2 {op4, op2 :: Int}
               | T3
\end{verbatim}
Then we translate as follows:
\begin{verbatim}
        r { op2 = e }
===>
        let op2 = e in
        case r of
          T1 op1 _ op3 -> T1 op1 op2 op3
          T2 op4 _     -> T2 op4 op2
          other        -> recUpdError "M.hs/230"
\end{verbatim}
It's important that we use the constructor Ids for @T1@, @T2@ etc on the
RHSs, and do not generate a Core constructor application directly, because the constructor
might do some argument-evaluation first; and may have to throw away some
dictionaries.

Note [Update for GADTs]
~~~~~~~~~~~~~~~~~~~~~~~
Consider
   data T a b where
     T1 :: { f1 :: a } -> T a Int

Then the wrapper function for T1 has type
   $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.

-}

dsExpr expr :: HsExpr GhcTc
expr@(RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcTc
record_expr, rupd_flds :: forall p. HsExpr p -> [LHsRecUpdField p]
rupd_flds = [LHsRecUpdField GhcTc]
fields
                       , rupd_ext :: forall p. HsExpr p -> XRecordUpd p
rupd_ext = RecordUpdTc
                           { rupd_cons :: RecordUpdTc -> [ConLike]
rupd_cons = [ConLike]
cons_to_upd
                           , rupd_in_tys :: RecordUpdTc -> [Type]
rupd_in_tys = [Type]
in_inst_tys
                           , rupd_out_tys :: RecordUpdTc -> [Type]
rupd_out_tys = [Type]
out_inst_tys
                           , rupd_wrap :: RecordUpdTc -> HsWrapper
rupd_wrap = HsWrapper
dict_req_wrap }} )
  | [LHsRecUpdField GhcTc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [LHsRecUpdField GhcTc]
fields
  = LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
record_expr
  | Bool
otherwise
  = ASSERT2( notNull cons_to_upd, ppr expr )

    do  { CoreExpr
record_expr' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
record_expr
        ; [(Name, Id, CoreExpr)]
field_binds' <- (LHsRecUpdField GhcTc
 -> IOEnv (Env DsGblEnv DsLclEnv) (Name, Id, CoreExpr))
-> [LHsRecUpdField GhcTc]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Name, Id, CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM LHsRecUpdField GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, Id, CoreExpr)
ds_field [LHsRecUpdField GhcTc]
fields
        ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
              upd_fld_env :: NameEnv Id
upd_fld_env = [(Name, Id)] -> NameEnv Id
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name
f,Id
l) | (Name
f,Id
l,CoreExpr
_) <- [(Name, Id, CoreExpr)]
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
        -- constructor arguments.
        ; [LMatch GhcTc (LHsExpr GhcTc)]
alts <- (ConLike
 -> IOEnv (Env DsGblEnv DsLclEnv) (LMatch GhcTc (LHsExpr GhcTc)))
-> [ConLike]
-> IOEnv (Env DsGblEnv DsLclEnv) [LMatch GhcTc (LHsExpr GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM (NameEnv Id
-> ConLike
-> IOEnv (Env DsGblEnv DsLclEnv) (LMatch GhcTc (LHsExpr GhcTc))
mk_alt NameEnv Id
upd_fld_env) [ConLike]
cons_to_upd
        ; ([Id
discrim_var], CoreExpr
matching_code)
                <- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper HsMatchContext GhcRn
forall p. HsMatchContext p
RecUpd (LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
forall a. a -> Maybe a
Just LHsExpr GhcTc
record_expr) -- See Note [Scrutinee in Record updates]
                                      (MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG { mg_alts :: Located [LMatch GhcTc (LHsExpr GhcTc)]
mg_alts = [LMatch GhcTc (LHsExpr GhcTc)]
-> Located [LMatch GhcTc (LHsExpr GhcTc)]
forall e. e -> Located e
noLoc [LMatch GhcTc (LHsExpr GhcTc)]
alts
                                          , mg_ext :: XMG GhcTc (LHsExpr GhcTc)
mg_ext = [Type] -> Type -> MatchGroupTc
MatchGroupTc [Type
in_ty] Type
out_ty
                                          , mg_origin :: Origin
mg_origin = Origin
FromSource })
                                     -- FromSource is not strictly right, but we
                                     -- want incomplete pattern-match warnings

        ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ([(Name, Id, CoreExpr)] -> CoreExpr -> CoreExpr
forall {a}. [(a, Id, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [(Name, Id, CoreExpr)]
field_binds' (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
                  Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
discrim_var CoreExpr
record_expr' CoreExpr
matching_code) }
  where
    ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
      -- Clone the Id in the HsRecField, because its Name is that
      -- of the record selector, and we must not make that a local binder
      -- else we shadow other uses of the record selector
      -- Hence 'lcl_id'.  Cf #2735
    ds_field :: LHsRecUpdField GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, Id, CoreExpr)
ds_field (L SrcSpan
_ HsRecUpdField GhcTc
rec_field)
      = do { CoreExpr
rhs <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (HsRecUpdField GhcTc -> LHsExpr GhcTc
forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecUpdField GhcTc
rec_field)
           ; let fld_id :: Id
fld_id = GenLocated SrcSpan Id -> Id
forall l e. GenLocated l e -> e
unLoc (HsRecUpdField GhcTc -> GenLocated SrcSpan Id
forall arg.
HsRecField' (AmbiguousFieldOcc GhcTc) arg -> GenLocated SrcSpan Id
hsRecUpdFieldId HsRecUpdField GhcTc
rec_field)
           ; Id
lcl_id <- Type -> DsM Id
newSysLocalDs (Id -> Type
idType Id
fld_id)
           ; (Name, Id, CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, Id, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Id -> Name
idName Id
fld_id, Id
lcl_id, CoreExpr
rhs) }

    add_field_binds :: [(a, Id, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [] CoreExpr
expr = CoreExpr
expr
    add_field_binds ((a
_,Id
b,CoreExpr
r):[(a, Id, CoreExpr)]
bs) CoreExpr
expr = Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
b CoreExpr
r ([(a, Id, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [(a, Id, CoreExpr)]
bs CoreExpr
expr)

        -- Awkwardly, for families, the match goes
        -- from instance type to family type
    (Type
in_ty, Type
out_ty) =
      case ([ConLike] -> ConLike
forall a. [a] -> a
head [ConLike]
cons_to_upd) of
        RealDataCon DataCon
data_con ->
          let tycon :: TyCon
tycon = DataCon -> TyCon
dataConTyCon DataCon
data_con in
          (TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type]
in_inst_tys, TyCon -> [Type] -> Type
mkFamilyTyConApp TyCon
tycon [Type]
out_inst_tys)
        PatSynCon PatSyn
pat_syn ->
          ( PatSyn -> [Type] -> Type
patSynInstResTy PatSyn
pat_syn [Type]
in_inst_tys
          , PatSyn -> [Type] -> Type
patSynInstResTy PatSyn
pat_syn [Type]
out_inst_tys)
    mk_alt :: NameEnv Id
-> ConLike
-> IOEnv (Env DsGblEnv DsLclEnv) (LMatch GhcTc (LHsExpr GhcTc))
mk_alt NameEnv Id
upd_fld_env ConLike
con
      = do { let ([Id]
univ_tvs, [Id]
ex_tvs, [EqSpec]
eq_spec,
                  [Type]
prov_theta, [Type]
_req_theta, [Type]
arg_tys, Type
_) = ConLike -> ([Id], [Id], [EqSpec], [Type], [Type], [Type], Type)
conLikeFullSig ConLike
con
                 user_tvs :: [Id]
user_tvs  = [VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars ([VarBndr Id Specificity] -> [Id])
-> [VarBndr Id Specificity] -> [Id]
forall a b. (a -> b) -> a -> b
$ ConLike -> [VarBndr Id Specificity]
conLikeUserTyVarBinders ConLike
con
                 in_subst :: TCvSubst
in_subst  = [Id] -> [Type] -> TCvSubst
HasDebugCallStack => [Id] -> [Type] -> TCvSubst
External instance of the constraint type HasDebugCallStack
zipTvSubst [Id]
univ_tvs [Type]
in_inst_tys
                 out_subst :: TCvSubst
out_subst = [Id] -> [Type] -> TCvSubst
HasDebugCallStack => [Id] -> [Type] -> TCvSubst
External instance of the constraint type HasDebugCallStack
zipTvSubst [Id]
univ_tvs [Type]
out_inst_tys

                -- I'm not bothering to clone the ex_tvs
           ; [Id]
eqs_vars   <- (Type -> DsM Id) -> [Type] -> DsM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM Type -> DsM Id
newPredVarDs (HasCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
in_subst ([EqSpec] -> [Type]
eqSpecPreds [EqSpec]
eq_spec))
           ; [Id]
theta_vars <- (Type -> DsM Id) -> [Type] -> DsM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM Type -> DsM Id
newPredVarDs (HasCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
in_subst [Type]
prov_theta)
           ; [Id]
arg_ids    <- [Type] -> DsM [Id]
newSysLocalsDs (TCvSubst -> [Type] -> [Type]
substTysUnchecked TCvSubst
in_subst [Type]
arg_tys)
           ; let field_labels :: [FieldLbl Name]
field_labels = ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con
                 val_args :: [LHsExpr GhcTc]
val_args = String
-> (FieldLbl Name -> Id -> LHsExpr GhcTc)
-> [FieldLbl Name]
-> [Id]
-> [LHsExpr GhcTc]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"dsExpr:RecordUpd" FieldLbl Name -> Id -> LHsExpr GhcTc
mk_val_arg
                                         [FieldLbl Name]
field_labels [Id]
arg_ids
                 mk_val_arg :: FieldLbl Name -> Id -> LHsExpr GhcTc
mk_val_arg FieldLbl Name
fl Id
pat_arg_id
                     = IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (NameEnv Id -> Name -> Maybe Id
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Id
upd_fld_env (FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector FieldLbl Name
fl) Maybe Id -> Id -> Id
forall a. Maybe a -> a -> a
`orElse` Id
pat_arg_id)

                 inst_con :: LHsExpr GhcTc
inst_con = HsExpr GhcTc -> LHsExpr GhcTc
forall e. e -> Located e
noLoc (HsExpr GhcTc -> LHsExpr GhcTc) -> HsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (XConLikeOut GhcTc -> ConLike -> HsExpr GhcTc
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut XConLikeOut GhcTc
NoExtField
noExtField ConLike
con)
                        -- Reconstruct with the WrapId so that unpacking happens
                 wrap :: HsWrapper
wrap = [Id] -> HsWrapper
mkWpEvVarApps [Id]
theta_vars                                HsWrapper -> HsWrapper -> HsWrapper
<.>
                        HsWrapper
dict_req_wrap                                           HsWrapper -> HsWrapper -> HsWrapper
<.>
                        [Type] -> HsWrapper
mkWpTyApps    [ TCvSubst -> Id -> Maybe Type
lookupTyVar TCvSubst
out_subst Id
tv
                                          Maybe Type -> Type -> Type
forall a. Maybe a -> a -> a
`orElse` Id -> Type
mkTyVarTy Id
tv
                                      | Id
tv <- [Id]
user_tvs
                                      , Bool -> Bool
not (Id
tv Id -> VarEnv TcCoercion -> Bool
forall a. Id -> VarEnv a -> Bool
`elemVarEnv` VarEnv TcCoercion
wrap_subst) ]
                          -- Be sure to use user_tvs (which may be ordered
                          -- differently than `univ_tvs ++ ex_tvs) above.
                          -- See Note [DataCon user type variable binders]
                          -- in GHC.Core.DataCon.
                 rhs :: LHsExpr GhcTc
rhs = (LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc)
-> LHsExpr GhcTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
External instance of the constraint type Foldable []
foldl' (\LHsExpr GhcTc
a LHsExpr GhcTc
b -> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Typechecked
nlHsApp LHsExpr GhcTc
a LHsExpr GhcTc
b) LHsExpr GhcTc
inst_con [LHsExpr GhcTc]
val_args

                        -- Tediously wrap the application in a cast
                        -- Note [Update for GADTs]
                 wrapped_rhs :: LHsExpr GhcTc
wrapped_rhs =
                  case ConLike
con of
                    RealDataCon DataCon
data_con ->
                      let
                        wrap_co :: TcCoercion
wrap_co =
                          Role -> TyCon -> [TcCoercion] -> TcCoercion
mkTcTyConAppCo Role
Nominal
                            (DataCon -> TyCon
dataConTyCon DataCon
data_con)
                            [ Id -> Type -> TcCoercion
lookup Id
tv Type
ty
                              | (Id
tv,Type
ty) <- [Id]
univ_tvs [Id] -> [Type] -> [(Id, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Type]
out_inst_tys ]
                        lookup :: Id -> Type -> TcCoercion
lookup Id
univ_tv Type
ty =
                          case VarEnv TcCoercion -> Id -> Maybe TcCoercion
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv TcCoercion
wrap_subst Id
univ_tv of
                            Just TcCoercion
co' -> TcCoercion
co'
                            Maybe TcCoercion
Nothing  -> Role -> Type -> TcCoercion
mkTcReflCo Role
Nominal Type
ty
                        in if [EqSpec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [EqSpec]
eq_spec
                             then LHsExpr GhcTc
rhs
                             else HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (TcCoercion -> HsWrapper
mkWpCastN TcCoercion
wrap_co) LHsExpr GhcTc
rhs
                    -- eq_spec is always null for a PatSynCon
                    PatSynCon PatSyn
_ -> LHsExpr GhcTc
rhs

                 wrap_subst :: VarEnv TcCoercion
wrap_subst =
                  [(Id, TcCoercion)] -> VarEnv TcCoercion
forall a. [(Id, a)] -> VarEnv a
mkVarEnv [ (Id
tv, TcCoercion -> TcCoercion
mkTcSymCo (Id -> TcCoercion
mkTcCoVarCo Id
eq_var))
                           | (EqSpec
spec, Id
eq_var) <- [EqSpec]
eq_spec [EqSpec] -> [Id] -> [(EqSpec, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
eqs_vars
                           , let tv :: Id
tv = EqSpec -> Id
eqSpecTyVar EqSpec
spec ]

                 req_wrap :: HsWrapper
req_wrap = HsWrapper
dict_req_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> [Type] -> HsWrapper
mkWpTyApps [Type]
in_inst_tys

                 pat :: Located (Pat GhcTc)
pat = Pat GhcTc -> Located (Pat GhcTc)
forall e. e -> Located e
noLoc (Pat GhcTc -> Located (Pat GhcTc))
-> Pat GhcTc -> Located (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat { pat_con :: Located (ConLikeP GhcTc)
pat_con = ConLike -> Located ConLike
forall e. e -> Located e
noLoc ConLike
con
                                      , pat_args :: HsConPatDetails GhcTc
pat_args = [Located (Pat GhcTc)]
-> HsConDetails
     (Located (Pat GhcTc)) (HsRecFields GhcTc (Located (Pat GhcTc)))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ([Located (Pat GhcTc)]
 -> HsConDetails
      (Located (Pat GhcTc)) (HsRecFields GhcTc (Located (Pat GhcTc))))
-> [Located (Pat GhcTc)]
-> HsConDetails
     (Located (Pat GhcTc)) (HsRecFields GhcTc (Located (Pat GhcTc)))
forall a b. (a -> b) -> a -> b
$ (Id -> Located (Pat GhcTc)) -> [Id] -> [Located (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Located (Pat GhcTc)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat [Id]
arg_ids
                                      , pat_con_ext :: XConPat GhcTc
pat_con_ext = ConPatTc :: [Type] -> [Id] -> [Id] -> TcEvBinds -> HsWrapper -> ConPatTc
ConPatTc
                                        { cpt_tvs :: [Id]
cpt_tvs = [Id]
ex_tvs
                                        , cpt_dicts :: [Id]
cpt_dicts = [Id]
eqs_vars [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
theta_vars
                                        , cpt_binds :: TcEvBinds
cpt_binds = TcEvBinds
emptyTcEvBinds
                                        , cpt_arg_tys :: [Type]
cpt_arg_tys = [Type]
in_inst_tys
                                        , cpt_wrap :: HsWrapper
cpt_wrap = HsWrapper
req_wrap
                                        }
                                      }
           ; LMatch GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) (LMatch GhcTc (LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (HsMatchContext (NoGhcTc GhcTc)
-> [LPat GhcTc] -> LHsExpr GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch HsMatchContext (NoGhcTc GhcTc)
forall p. HsMatchContext p
RecUpd [Located (Pat GhcTc)
LPat GhcTc
pat] LHsExpr GhcTc
wrapped_rhs) }

{- Note [Scrutinee in Record updates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider #17783:

  data PartialRec = No
                  | Yes { a :: Int, b :: Bool }
  update No = No
  update r@(Yes {}) = r { b = False }

In the context of pattern-match checking, the occurrence of @r@ in
@r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by
the following desugaring:

  r { b = False } ==> case r of Yes a b -> Yes a False

Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.
-}

-- Here is where we desugar the Template Haskell brackets and escapes

-- Template Haskell stuff

dsExpr (HsRnBracketOut XRnBracketOut GhcTc
_ HsBracket GhcRn
_ [PendingRnSplice]
_)  = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr HsRnBracketOut"
dsExpr (HsTcBracketOut XTcBracketOut GhcTc
_ Maybe QuoteWrapper
hs_wrapper HsBracket GhcRn
x [PendingTcSplice]
ps) = Maybe QuoteWrapper
-> HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr
dsBracket Maybe QuoteWrapper
hs_wrapper HsBracket GhcRn
x [PendingTcSplice]
ps
dsExpr (HsSpliceE XSpliceE GhcTc
_ HsSplice GhcTc
s)         = String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsExpr:splice" (HsSplice GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsSplice (GhcPass p))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr HsSplice GhcTc
s)

-- Arrow notation extension
dsExpr (HsProc XProc GhcTc
_ LPat GhcTc
pat LHsCmdTop GhcTc
cmd) = LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr
dsProcExpr LPat GhcTc
pat LHsCmdTop GhcTc
cmd

-- Hpc Support

dsExpr (HsTick XTick GhcTc
_ Tickish (IdP GhcTc)
tickish LHsExpr GhcTc
e) = do
  CoreExpr
e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
  CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
Tickish (IdP GhcTc)
tickish CoreExpr
e')

-- 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 XBinTick GhcTc
_ Int
ixT Int
ixF LHsExpr GhcTc
e) = do
  CoreExpr
e2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
  do { ASSERT(exprType e2 `eqType` boolTy)
       Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox Int
ixT Int
ixF CoreExpr
e2
     }

-- HsSyn constructs that just shouldn't be here:
dsExpr (HsBracket     {})  = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr:HsBracket"
dsExpr (HsDo          {})  = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr:HsDo"
dsExpr (HsRecFld      {})  = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr:HsRecFld"

ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
ds_prag_expr (HsPragSCC XSCC GhcTc
_ SourceText
_ StringLiteral
cc) LHsExpr GhcTc
expr = do
    DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
    if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags
      then do
        Module
mod_name <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
External instance of the constraint type forall env. ContainsModule env => HasModule (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsModule gbl => ContainsModule (Env gbl lcl)
External instance of the constraint type ContainsModule DsGblEnv
getModule
        Bool
count <- GeneralFlag -> TcRnIf DsGblEnv DsLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ProfCountEntries
        let nm :: FieldLabelString
nm = StringLiteral -> FieldLabelString
sl_fs StringLiteral
cc
        CCFlavour
flavour <- CostCentreIndex -> CCFlavour
ExprCC (CostCentreIndex -> CCFlavour)
-> IOEnv (Env DsGblEnv DsLclEnv) CostCentreIndex
-> IOEnv (Env DsGblEnv DsLclEnv) CCFlavour
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
<$> FieldLabelString -> IOEnv (Env DsGblEnv DsLclEnv) CostCentreIndex
forall gbl lcl.
ContainsCostCentreState gbl =>
FieldLabelString -> TcRnIf gbl lcl CostCentreIndex
External instance of the constraint type ContainsCostCentreState DsGblEnv
getCCIndexM FieldLabelString
nm
        Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick (CostCentre -> Bool -> Bool -> Tickish Id
forall id. CostCentre -> Bool -> Bool -> Tickish id
ProfNote (FieldLabelString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC FieldLabelString
nm Module
mod_name (LHsExpr GhcTc -> SrcSpan
forall l e. GenLocated l e -> l
getLoc LHsExpr GhcTc
expr) CCFlavour
flavour) Bool
count Bool
True)
               (CoreExpr -> CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
<$> LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
      else LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
ds_prag_expr (HsPragCore XCoreAnn GhcTc
_ SourceText
_ StringLiteral
_) LHsExpr GhcTc
expr
  = LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
ds_prag_expr (HsPragTick XTickPragma GhcTc
_ SourceText
_ (StringLiteral, (Int, Int), (Int, Int))
_ ((SourceText, SourceText), (SourceText, SourceText))
_) LHsExpr GhcTc
expr = do
  DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
  if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Hpc DynFlags
dflags
    then String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr:HsPragTick"
    else LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr

------------------------------
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (SyntaxExprTc { syn_expr :: SyntaxExprTc -> HsExpr GhcTc
syn_expr      = HsExpr GhcTc
expr
                           , syn_arg_wraps :: SyntaxExprTc -> [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps
                           , syn_res_wrap :: SyntaxExprTc -> HsWrapper
syn_res_wrap  = HsWrapper
res_wrap })
             [CoreExpr]
arg_exprs
  = do { CoreExpr
fun            <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
       ; [CoreExpr -> CoreExpr]
core_arg_wraps <- (HsWrapper -> DsM (CoreExpr -> CoreExpr))
-> [HsWrapper]
-> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr -> CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper [HsWrapper]
arg_wraps
       ; CoreExpr -> CoreExpr
core_res_wrap  <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
res_wrap
       ; let wrapped_args :: [CoreExpr]
wrapped_args = String
-> ((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> [CoreExpr -> CoreExpr]
-> [CoreExpr]
-> [CoreExpr]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"dsSyntaxExpr" (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
($) [CoreExpr -> CoreExpr]
core_arg_wraps [CoreExpr]
arg_exprs
       ; IOEnv (Env DsGblEnv DsLclEnv) ()
-> (() -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs ((CoreExpr -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ())
-> [CoreExpr] -> [SDoc] -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
External instance of the constraint type forall m. Applicative (IOEnv m)
zipWithM_ CoreExpr -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
dsNoLevPolyExpr [CoreExpr]
wrapped_args [ Int -> SDoc
mk_doc Int
n | Int
n <- [Int
1..] ])
                      (\()
_ -> CoreExpr -> CoreExpr
core_res_wrap (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
fun [CoreExpr]
wrapped_args)) }
  where
    mk_doc :: Int -> SDoc
mk_doc Int
n = String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
n SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"argument of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr HsExpr GhcTc
expr)
dsSyntaxExpr SyntaxExpr GhcTc
SyntaxExprTc
NoSyntaxExprTc [CoreExpr]
_ = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsSyntaxExpr"

findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
findField [LHsRecField GhcTc arg]
rbinds Name
sel
  = [HsRecField' (FieldOcc GhcTc) arg -> arg
forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField' (FieldOcc GhcTc) arg
fld | L SrcSpan
_ HsRecField' (FieldOcc GhcTc) arg
fld <- [LHsRecField GhcTc arg]
rbinds
                       , Name
sel Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Name
== Id -> Name
idName (GenLocated SrcSpan Id -> Id
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan Id -> Id) -> GenLocated SrcSpan Id -> Id
forall a b. (a -> b) -> a -> b
$ HsRecField' (FieldOcc GhcTc) arg -> GenLocated SrcSpan Id
forall arg. HsRecField GhcTc arg -> GenLocated SrcSpan Id
hsRecFieldId HsRecField' (FieldOcc GhcTc) arg
fld) ]

{-
%--------------------------------------------------------------------

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

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

 * build/foldr fusion can generate far larger code than the corresponding
   cons-chain (e.g. see #11707)

 * 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

 * when it works, fusion can be a significant win. Allocations are reduced
   by up to 25% in some nofib programs. Specifically,

        Program           Size    Allocs   Runtime  CompTime
        rewrite          +0.0%    -26.3%      0.02     -1.8%
           ansi          -0.3%    -13.8%      0.00     +0.0%
           lift          +0.0%     -8.7%      0.00     -2.3%

At the moment we use a simple heuristic to determine whether build will be
fruitful: for small lists we assume the benefits of fusion will be worthwhile;
for long lists we assume that the benefits will be outweighted by the cost of
code duplication. This magic length threshold is @maxBuildLength@. Also, fusion
won't work at all if rewrite rules are disabled, so we don't use the build-based
desugaring in this case.

We used to have a more complex heuristic which would try to break the list into
"static" and "dynamic" parts and only build-desugar the dynamic part.
Unfortunately, determining "static-ness" reliably is a bit tricky and the
heuristic at times produced surprising behavior (see #11710) so it was dropped.
-}

{- | The longest list length which we will desugar using @build@.

This is essentially a magic number and its setting is unfortunate rather
arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],
is to avoid deforesting large static data into large(r) code. Ideally we'd
want a smaller threshold with larger consumers and vice-versa, but we have no
way of knowing what will be consuming our list in the desugaring impossible to
set generally correctly.

The effect of reducing this number will be that 'build' fusion is applied
less often. From a runtime performance perspective, applying 'build' more
liberally on "moderately" sized lists should rarely hurt and will often it can
only expose further optimization opportunities; if no fusion is possible it will
eventually get rule-rewritten back to a list). We do, however, pay in compile
time.
-}
maxBuildLength :: Int
maxBuildLength :: Int
maxBuildLength = Int
32

dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc]
               -> DsM CoreExpr
-- See Note [Desugaring explicit lists]
dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> DsM CoreExpr
dsExplicitList Type
elt_ty Maybe (SyntaxExpr GhcTc)
Nothing [LHsExpr GhcTc]
xs
  = do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
       ; [CoreExpr]
xs' <- (LHsExpr GhcTc -> DsM CoreExpr)
-> [LHsExpr GhcTc] -> DsM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP [LHsExpr GhcTc]
xs
       ; if [CoreExpr]
xs' [CoreExpr] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
maxBuildLength
                -- Don't generate builds if the list is very long.
         Bool -> Bool -> Bool
|| [CoreExpr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [CoreExpr]
xs'
                -- Don't generate builds when the [] constructor will do
         Bool -> Bool -> Bool
|| Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EnableRewriteRules DynFlags
dflags)  -- Rewrite rules off
                -- Don't generate a build if there are no rules to eliminate it!
                -- See Note [Desugaring RULE left hand sides] in GHC.HsToCore
         then CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ Type -> [CoreExpr] -> CoreExpr
mkListExpr Type
elt_ty [CoreExpr]
xs'
         else Type -> ((Id, Type) -> (Id, Type) -> DsM CoreExpr) -> DsM CoreExpr
forall (m :: * -> *).
(MonadFail m, MonadThings m, MonadUnique m) =>
Type -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -> m CoreExpr
External instance of the constraint type forall gbl lcl. MonadUnique (IOEnv (Env gbl lcl))
External instance of the constraint type MonadThings (IOEnv (Env DsGblEnv DsLclEnv))
External instance of the constraint type forall m. MonadFail (IOEnv m)
mkBuildExpr Type
elt_ty ([CoreExpr] -> (Id, Type) -> (Id, Type) -> DsM CoreExpr
forall {m :: * -> *} {t :: * -> *} {b} {b} {b}.
(Monad m, Foldable t) =>
t (Arg b) -> (Id, b) -> (Id, b) -> m (Arg b)
External instance of the constraint type Foldable []
External instance of the constraint type forall m. Monad (IOEnv m)
mk_build_list [CoreExpr]
xs') }
  where
    mk_build_list :: t (Arg b) -> (Id, b) -> (Id, b) -> m (Arg b)
mk_build_list t (Arg b)
xs' (Id
cons, b
_) (Id
nil, b
_)
      = Arg b -> m (Arg b)
forall (m :: * -> *) a. Monad m => a -> m a
Evidence bound by a type signature of the constraint type Monad m
return ((Arg b -> Arg b -> Arg b) -> Arg b -> t (Arg b) -> Arg b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Evidence bound by a type signature of the constraint type Foldable t
foldr (Arg b -> Arg b -> Arg b
forall b. Expr b -> Expr b -> Expr b
App (Arg b -> Arg b -> Arg b)
-> (Arg b -> Arg b) -> Arg b -> Arg b -> Arg b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg b -> Arg b -> Arg b
forall b. Expr b -> Expr b -> Expr b
App (Id -> Arg b
forall b. Id -> Expr b
Var Id
cons)) (Id -> Arg b
forall b. Id -> Expr b
Var Id
nil) t (Arg b)
xs')

dsExplicitList Type
elt_ty (Just SyntaxExpr GhcTc
fln) [LHsExpr GhcTc]
xs
  = do { CoreExpr
list <- Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> DsM CoreExpr
dsExplicitList Type
elt_ty Maybe (SyntaxExpr GhcTc)
forall a. Maybe a
Nothing [LHsExpr GhcTc]
xs
       ; DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
       ; let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
       ; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
fln [Platform -> Int -> CoreExpr
mkIntExprInt Platform
platform ([LHsExpr GhcTc] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
External instance of the constraint type Foldable []
length [LHsExpr GhcTc]
xs), CoreExpr
list] }

dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
dsArithSeq :: HsExpr GhcTc -> ArithSeqInfo GhcTc -> DsM CoreExpr
dsArithSeq HsExpr GhcTc
expr (From LHsExpr GhcTc
from)
  = CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr -> CoreExpr)
-> DsM CoreExpr -> DsM (CoreExpr -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
<$> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr DsM (CoreExpr -> CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
External instance of the constraint type forall m. Applicative (IOEnv m)
<*> LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
from
dsArithSeq HsExpr GhcTc
expr (FromTo LHsExpr GhcTc
from LHsExpr GhcTc
to)
  = do DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
       DynFlags
-> LHsExpr GhcTc
-> Maybe (LHsExpr GhcTc)
-> LHsExpr GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutEmptyEnumerations DynFlags
dflags LHsExpr GhcTc
from Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing LHsExpr GhcTc
to
       CoreExpr
expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
       CoreExpr
from' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
from
       CoreExpr
to'   <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
to
       CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
expr' [CoreExpr
from', CoreExpr
to']
dsArithSeq HsExpr GhcTc
expr (FromThen LHsExpr GhcTc
from LHsExpr GhcTc
thn)
  = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreExpr -> [CoreExpr] -> CoreExpr)
-> DsM CoreExpr
-> IOEnv (Env DsGblEnv DsLclEnv) ([CoreExpr] -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type forall env. Functor (IOEnv env)
<$> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr IOEnv (Env DsGblEnv DsLclEnv) ([CoreExpr] -> CoreExpr)
-> DsM [CoreExpr] -> DsM CoreExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
External instance of the constraint type forall m. Applicative (IOEnv m)
<*> (LHsExpr GhcTc -> DsM CoreExpr)
-> [LHsExpr GhcTc] -> DsM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP [LHsExpr GhcTc
from, LHsExpr GhcTc
thn]
dsArithSeq HsExpr GhcTc
expr (FromThenTo LHsExpr GhcTc
from LHsExpr GhcTc
thn LHsExpr GhcTc
to)
  = do DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
       DynFlags
-> LHsExpr GhcTc
-> Maybe (LHsExpr GhcTc)
-> LHsExpr GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutEmptyEnumerations DynFlags
dflags LHsExpr GhcTc
from (LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
forall a. a -> Maybe a
Just LHsExpr GhcTc
thn) LHsExpr GhcTc
to
       CoreExpr
expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
       CoreExpr
from' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
from
       CoreExpr
thn'  <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
thn
       CoreExpr
to'   <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
to
       CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
expr' [CoreExpr
from', CoreExpr
thn', CoreExpr
to']

{-
Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
handled in GHC.HsToCore.ListComp).  Basically does the translation given in the
Haskell 98 report:
-}

dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo [ExprLStmt GhcTc]
stmts
  = [ExprLStmt GhcTc] -> DsM CoreExpr
goL [ExprLStmt GhcTc]
stmts
  where
    goL :: [ExprLStmt GhcTc] -> DsM CoreExpr
goL [] = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsDo"
    goL ((L SrcSpan
loc StmtLR GhcTc GhcTc (LHsExpr GhcTc)
stmt):[ExprLStmt GhcTc]
lstmts) = SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (SrcSpan
-> StmtLR GhcTc GhcTc (LHsExpr GhcTc)
-> [ExprLStmt GhcTc]
-> DsM CoreExpr
go SrcSpan
loc StmtLR GhcTc GhcTc (LHsExpr GhcTc)
stmt [ExprLStmt GhcTc]
lstmts)

    go :: SrcSpan
-> StmtLR GhcTc GhcTc (LHsExpr GhcTc)
-> [ExprLStmt GhcTc]
-> DsM CoreExpr
go SrcSpan
_ (LastStmt XLastStmt GhcTc GhcTc (LHsExpr GhcTc)
_ LHsExpr GhcTc
body Maybe Bool
_ SyntaxExpr GhcTc
_) [ExprLStmt GhcTc]
stmts
      = ASSERT( null stmts ) dsLExpr body
        -- The 'return' op isn't used for 'do' expressions

    go SrcSpan
_ (BodyStmt XBodyStmt GhcTc GhcTc (LHsExpr GhcTc)
_ LHsExpr GhcTc
rhs SyntaxExpr GhcTc
then_expr SyntaxExpr GhcTc
_) [ExprLStmt GhcTc]
stmts
      = do { CoreExpr
rhs2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
rhs
           ; LHsExpr GhcTc -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDiscardedDoBindings LHsExpr GhcTc
rhs (CoreExpr -> Type
exprType CoreExpr
rhs2)
           ; CoreExpr
rest <- [ExprLStmt GhcTc] -> DsM CoreExpr
goL [ExprLStmt GhcTc]
stmts
           ; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
then_expr [CoreExpr
rhs2, CoreExpr
rest] }

    go SrcSpan
_ (LetStmt XLetStmt GhcTc GhcTc (LHsExpr GhcTc)
_ LHsLocalBinds GhcTc
binds) [ExprLStmt GhcTc]
stmts
      = do { CoreExpr
rest <- [ExprLStmt GhcTc] -> DsM CoreExpr
goL [ExprLStmt GhcTc]
stmts
           ; LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds LHsLocalBinds GhcTc
binds CoreExpr
rest }

    go SrcSpan
_ (BindStmt XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
xbs LPat GhcTc
pat LHsExpr GhcTc
rhs) [ExprLStmt GhcTc]
stmts
      = do  { CoreExpr
body     <- [ExprLStmt GhcTc] -> DsM CoreExpr
goL [ExprLStmt GhcTc]
stmts
            ; CoreExpr
rhs'     <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
rhs
            ; Id
var   <- LPat GhcTc -> DsM Id
selectSimpleMatchVarL LPat GhcTc
pat
            ; MatchResult CoreExpr
match <- Id
-> HsMatchContext GhcRn
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar Id
var (HsStmtContext GhcRn -> HsMatchContext GhcRn
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
forall p. HsStmtContext p
DoExpr) LPat GhcTc
pat
                         (XBindStmtTc -> Type
xbstc_boundResultType XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
XBindStmtTc
xbs) (CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
body)
            ; CoreExpr
match_code <- LPat GhcTc
-> MatchResult CoreExpr -> Maybe (SyntaxExpr GhcTc) -> DsM CoreExpr
dsHandleMonadicFailure LPat GhcTc
pat MatchResult CoreExpr
match (XBindStmtTc -> Maybe (SyntaxExpr GhcTc)
xbstc_failOp XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
XBindStmtTc
xbs)
            ; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (XBindStmtTc -> SyntaxExpr GhcTc
xbstc_bindOp XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
XBindStmtTc
xbs) [CoreExpr
rhs', Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
var CoreExpr
match_code] }

    go SrcSpan
_ (ApplicativeStmt XApplicativeStmt GhcTc GhcTc (LHsExpr GhcTc)
body_ty [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args Maybe (SyntaxExpr GhcTc)
mb_join) [ExprLStmt GhcTc]
stmts
      = do {
             let
               ([(Located (Pat GhcTc), Maybe SyntaxExprTc)]
pats, [DsM CoreExpr]
rhss) = [((Located (Pat GhcTc), Maybe SyntaxExprTc), DsM CoreExpr)]
-> ([(Located (Pat GhcTc), Maybe SyntaxExprTc)], [DsM CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip (((SyntaxExprTc, ApplicativeArg GhcTc)
 -> ((Located (Pat GhcTc), Maybe SyntaxExprTc), DsM CoreExpr))
-> [(SyntaxExprTc, ApplicativeArg GhcTc)]
-> [((Located (Pat GhcTc), Maybe SyntaxExprTc), DsM CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (ApplicativeArg GhcTc
-> ((Located (Pat GhcTc), Maybe SyntaxExprTc), DsM CoreExpr)
do_arg (ApplicativeArg GhcTc
 -> ((Located (Pat GhcTc), Maybe SyntaxExprTc), DsM CoreExpr))
-> ((SyntaxExprTc, ApplicativeArg GhcTc) -> ApplicativeArg GhcTc)
-> (SyntaxExprTc, ApplicativeArg GhcTc)
-> ((Located (Pat GhcTc), Maybe SyntaxExprTc), DsM CoreExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SyntaxExprTc, ApplicativeArg GhcTc) -> ApplicativeArg GhcTc
forall a b. (a, b) -> b
snd) [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
[(SyntaxExprTc, ApplicativeArg GhcTc)]
args)

               do_arg :: ApplicativeArg GhcTc
-> ((Located (Pat GhcTc), Maybe SyntaxExprTc), DsM CoreExpr)
do_arg (ApplicativeArgOne XApplicativeArgOne GhcTc
fail_op LPat GhcTc
pat LHsExpr GhcTc
expr Bool
_) =
                 ((Located (Pat GhcTc)
LPat GhcTc
pat, Maybe SyntaxExprTc
XApplicativeArgOne GhcTc
fail_op), LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr)
               do_arg (ApplicativeArgMany XApplicativeArgMany GhcTc
_ [ExprLStmt GhcTc]
stmts HsExpr GhcTc
ret LPat GhcTc
pat) =
                 ((Located (Pat GhcTc)
LPat GhcTc
pat, Maybe SyntaxExprTc
forall a. Maybe a
Nothing), [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo ([ExprLStmt GhcTc]
stmts [ExprLStmt GhcTc] -> [ExprLStmt GhcTc] -> [ExprLStmt GhcTc]
forall a. [a] -> [a] -> [a]
++ [StmtLR GhcTc GhcTc (LHsExpr GhcTc) -> ExprLStmt GhcTc
forall e. e -> Located e
noLoc (StmtLR GhcTc GhcTc (LHsExpr GhcTc) -> ExprLStmt GhcTc)
-> StmtLR GhcTc GhcTc (LHsExpr GhcTc) -> ExprLStmt GhcTc
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTc -> StmtLR GhcTc GhcTc (LHsExpr GhcTc)
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
Located (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
External instance of the constraint type IsPass 'Typechecked
mkLastStmt (HsExpr GhcTc -> LHsExpr GhcTc
forall e. e -> Located e
noLoc HsExpr GhcTc
ret)]))

           ; [CoreExpr]
rhss' <- [DsM CoreExpr] -> DsM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
sequence [DsM CoreExpr]
rhss

           ; CoreExpr
body' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (LHsExpr GhcTc -> DsM CoreExpr) -> LHsExpr GhcTc -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> LHsExpr GhcTc
forall e. e -> Located e
noLoc (HsExpr GhcTc -> LHsExpr GhcTc) -> HsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XDo GhcTc
-> HsStmtContext GhcRn
-> GenLocated SrcSpan [ExprLStmt GhcTc]
-> HsExpr GhcTc
forall p.
XDo p -> HsStmtContext GhcRn -> Located [ExprLStmt p] -> HsExpr p
HsDo XApplicativeStmt GhcTc GhcTc (LHsExpr GhcTc)
XDo GhcTc
body_ty HsStmtContext GhcRn
forall p. HsStmtContext p
DoExpr ([ExprLStmt GhcTc] -> GenLocated SrcSpan [ExprLStmt GhcTc]
forall e. e -> Located e
noLoc [ExprLStmt GhcTc]
stmts)

           ; let match_args :: (Located (Pat GhcTc), Maybe SyntaxExprTc)
-> ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
match_args (Located (Pat GhcTc)
pat, Maybe SyntaxExprTc
fail_op) ([Id]
vs,CoreExpr
body)
                   = do { Id
var   <- LPat GhcTc -> DsM Id
selectSimpleMatchVarL Located (Pat GhcTc)
LPat GhcTc
pat
                        ; MatchResult CoreExpr
match <- Id
-> HsMatchContext GhcRn
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar Id
var (HsStmtContext GhcRn -> HsMatchContext GhcRn
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
forall p. HsStmtContext p
DoExpr) Located (Pat GhcTc)
LPat GhcTc
pat
                                   Type
XApplicativeStmt GhcTc GhcTc (LHsExpr GhcTc)
body_ty (CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
body)
                        ; CoreExpr
match_code <- LPat GhcTc
-> MatchResult CoreExpr -> Maybe (SyntaxExpr GhcTc) -> DsM CoreExpr
dsHandleMonadicFailure Located (Pat GhcTc)
LPat GhcTc
pat MatchResult CoreExpr
match Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
fail_op
                        ; ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Id
varId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
vs, CoreExpr
match_code)
                        }

           ; ([Id]
vars, CoreExpr
body) <- ((Located (Pat GhcTc), Maybe SyntaxExprTc)
 -> ([Id], CoreExpr) -> DsM ([Id], CoreExpr))
-> ([Id], CoreExpr)
-> [(Located (Pat GhcTc), Maybe SyntaxExprTc)]
-> DsM ([Id], CoreExpr)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
foldrM (Located (Pat GhcTc), Maybe SyntaxExprTc)
-> ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
match_args ([],CoreExpr
body') [(Located (Pat GhcTc), Maybe SyntaxExprTc)]
pats
           ; let fun' :: CoreExpr
fun' = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
vars CoreExpr
body
           ; let mk_ap_call :: CoreExpr -> (SyntaxExprTc, CoreExpr) -> DsM CoreExpr
mk_ap_call CoreExpr
l (SyntaxExprTc
op,CoreExpr
r) = SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
SyntaxExprTc
op [CoreExpr
l,CoreExpr
r]
           ; CoreExpr
expr <- (CoreExpr -> (SyntaxExprTc, CoreExpr) -> DsM CoreExpr)
-> CoreExpr -> [(SyntaxExprTc, CoreExpr)] -> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Foldable []
foldlM CoreExpr -> (SyntaxExprTc, CoreExpr) -> DsM CoreExpr
mk_ap_call CoreExpr
fun' ([SyntaxExprTc] -> [CoreExpr] -> [(SyntaxExprTc, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((SyntaxExprTc, ApplicativeArg GhcTc) -> SyntaxExprTc)
-> [(SyntaxExprTc, ApplicativeArg GhcTc)] -> [SyntaxExprTc]
forall a b. (a -> b) -> [a] -> [b]
map (SyntaxExprTc, ApplicativeArg GhcTc) -> SyntaxExprTc
forall a b. (a, b) -> a
fst [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
[(SyntaxExprTc, ApplicativeArg GhcTc)]
args) [CoreExpr]
rhss')
           ; case Maybe (SyntaxExpr GhcTc)
mb_join of
               Maybe (SyntaxExpr GhcTc)
Nothing -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return CoreExpr
expr
               Just SyntaxExpr GhcTc
join_op -> SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
join_op [CoreExpr
expr] }

    go SrcSpan
loc (RecStmt { recS_stmts :: forall idL idR body. StmtLR idL idR body -> [LStmtLR idL idR body]
recS_stmts = [ExprLStmt GhcTc]
rec_stmts, recS_later_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_later_ids = [IdP GhcTc]
later_ids
                    , recS_rec_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_rec_ids = [IdP GhcTc]
rec_ids, recS_ret_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_ret_fn = SyntaxExpr GhcTc
return_op
                    , recS_mfix_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_mfix_fn = SyntaxExpr GhcTc
mfix_op, recS_bind_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_bind_fn = SyntaxExpr GhcTc
bind_op
                    , recS_ext :: forall idL idR body. StmtLR idL idR body -> XRecStmt idL idR body
recS_ext = RecStmtTc
                        { recS_bind_ty :: RecStmtTc -> Type
recS_bind_ty = Type
bind_ty
                        , recS_rec_rets :: RecStmtTc -> [HsExpr GhcTc]
recS_rec_rets = [HsExpr GhcTc]
rec_rets
                        , recS_ret_ty :: RecStmtTc -> Type
recS_ret_ty = Type
body_ty} }) [ExprLStmt GhcTc]
stmts
      = [ExprLStmt GhcTc] -> DsM CoreExpr
goL (ExprLStmt GhcTc
new_bind_stmt ExprLStmt GhcTc -> [ExprLStmt GhcTc] -> [ExprLStmt GhcTc]
forall a. a -> [a] -> [a]
: [ExprLStmt GhcTc]
stmts)  -- rec_ids can be empty; eg  rec { print 'x' }
      where
        new_bind_stmt :: ExprLStmt GhcTc
new_bind_stmt = SrcSpan -> StmtLR GhcTc GhcTc (LHsExpr GhcTc) -> ExprLStmt GhcTc
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (StmtLR GhcTc GhcTc (LHsExpr GhcTc) -> ExprLStmt GhcTc)
-> StmtLR GhcTc GhcTc (LHsExpr GhcTc) -> ExprLStmt GhcTc
forall a b. (a -> b) -> a -> b
$ XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
-> LPat GhcTc
-> LHsExpr GhcTc
-> StmtLR GhcTc GhcTc (LHsExpr GhcTc)
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt
          XBindStmtTc :: SyntaxExpr GhcTc -> Type -> Maybe (SyntaxExpr GhcTc) -> XBindStmtTc
XBindStmtTc
            { xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp = SyntaxExpr GhcTc
bind_op
            , xbstc_boundResultType :: Type
xbstc_boundResultType = Type
bind_ty
            , xbstc_failOp :: Maybe (SyntaxExpr GhcTc)
xbstc_failOp = Maybe (SyntaxExpr GhcTc)
forall a. Maybe a
Nothing -- Tuple cannot fail
            }
          ([LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId [Located (Pat GhcTc)]
[LPat GhcTc]
later_pats)
          LHsExpr GhcTc
mfix_app

        tup_ids :: [Id]
tup_ids      = [Id]
[IdP GhcTc]
rec_ids [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Id -> [Id] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
External instance of the constraint type Eq Id
External instance of the constraint type Foldable []
`elem` [Id]
[IdP GhcTc]
rec_ids) [Id]
[IdP GhcTc]
later_ids
        tup_ty :: Type
tup_ty       = [Type] -> Type
mkBigCoreTupTy ((Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
tup_ids) -- Deals with singleton case
        rec_tup_pats :: [Located (Pat GhcTc)]
rec_tup_pats = (Id -> Located (Pat GhcTc)) -> [Id] -> [Located (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Located (Pat GhcTc)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat [Id]
tup_ids
        later_pats :: [Located (Pat GhcTc)]
later_pats   = [Located (Pat GhcTc)]
rec_tup_pats
        rets :: [LHsExpr GhcTc]
rets         = (HsExpr GhcTc -> LHsExpr GhcTc)
-> [HsExpr GhcTc] -> [LHsExpr GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map HsExpr GhcTc -> LHsExpr GhcTc
forall e. e -> Located e
noLoc [HsExpr GhcTc]
rec_rets
        mfix_app :: LHsExpr GhcTc
mfix_app     = SyntaxExprTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
nlHsSyntaxApps SyntaxExpr GhcTc
SyntaxExprTc
mfix_op [LHsExpr GhcTc
mfix_arg]
        mfix_arg :: LHsExpr GhcTc
mfix_arg     = HsExpr GhcTc -> LHsExpr GhcTc
forall e. e -> Located e
noLoc (HsExpr GhcTc -> LHsExpr GhcTc) -> HsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XLam GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcTc
NoExtField
noExtField
                           (MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG { mg_alts :: Located [LMatch GhcTc (LHsExpr GhcTc)]
mg_alts = [LMatch GhcTc (LHsExpr GhcTc)]
-> Located [LMatch GhcTc (LHsExpr GhcTc)]
forall e. e -> Located e
noLoc [HsMatchContext (NoGhcTc GhcTc)
-> [LPat GhcTc] -> LHsExpr GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch
                                                    HsMatchContext (NoGhcTc GhcTc)
forall p. HsMatchContext p
LambdaExpr
                                                    [Located (Pat GhcTc)
LPat GhcTc
mfix_pat] LHsExpr GhcTc
body]
                               , mg_ext :: XMG GhcTc (LHsExpr GhcTc)
mg_ext = [Type] -> Type -> MatchGroupTc
MatchGroupTc [Type
tup_ty] Type
body_ty
                               , mg_origin :: Origin
mg_origin = Origin
Generated })
        mfix_pat :: Located (Pat GhcTc)
mfix_pat     = Pat GhcTc -> Located (Pat GhcTc)
forall e. e -> Located e
noLoc (Pat GhcTc -> Located (Pat GhcTc))
-> Pat GhcTc -> Located (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$ XLazyPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XLazyPat p -> LPat p -> Pat p
LazyPat XLazyPat GhcTc
NoExtField
noExtField (LPat GhcTc -> Pat GhcTc) -> LPat GhcTc -> Pat GhcTc
forall a b. (a -> b) -> a -> b
$ [LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId [Located (Pat GhcTc)]
[LPat GhcTc]
rec_tup_pats
        body :: LHsExpr GhcTc
body         = HsExpr GhcTc -> LHsExpr GhcTc
forall e. e -> Located e
noLoc (HsExpr GhcTc -> LHsExpr GhcTc) -> HsExpr GhcTc -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XDo GhcTc
-> HsStmtContext GhcRn
-> GenLocated SrcSpan [ExprLStmt GhcTc]
-> HsExpr GhcTc
forall p.
XDo p -> HsStmtContext GhcRn -> Located [ExprLStmt p] -> HsExpr p
HsDo Type
XDo GhcTc
body_ty
                                HsStmtContext GhcRn
forall p. HsStmtContext p
DoExpr ([ExprLStmt GhcTc] -> GenLocated SrcSpan [ExprLStmt GhcTc]
forall e. e -> Located e
noLoc ([ExprLStmt GhcTc]
rec_stmts [ExprLStmt GhcTc] -> [ExprLStmt GhcTc] -> [ExprLStmt GhcTc]
forall a. [a] -> [a] -> [a]
++ [ExprLStmt GhcTc
ret_stmt]))
        ret_app :: LHsExpr GhcTc
ret_app      = SyntaxExprTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
nlHsSyntaxApps SyntaxExpr GhcTc
SyntaxExprTc
return_op [[LHsExpr GhcTc] -> LHsExpr GhcTc
mkBigLHsTupId [LHsExpr GhcTc]
rets]
        ret_stmt :: ExprLStmt GhcTc
ret_stmt     = StmtLR GhcTc GhcTc (LHsExpr GhcTc) -> ExprLStmt GhcTc
forall e. e -> Located e
noLoc (StmtLR GhcTc GhcTc (LHsExpr GhcTc) -> ExprLStmt GhcTc)
-> StmtLR GhcTc GhcTc (LHsExpr GhcTc) -> ExprLStmt GhcTc
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTc -> StmtLR GhcTc GhcTc (LHsExpr GhcTc)
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
Located (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
External instance of the constraint type IsPass 'Typechecked
mkLastStmt LHsExpr GhcTc
ret_app
                     -- This LastStmt will be desugared with dsDo,
                     -- which ignores the return_op in the LastStmt,
                     -- so we must apply the return_op explicitly

    go SrcSpan
_ (ParStmt   {}) [ExprLStmt GhcTc]
_ = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsDo ParStmt"
    go SrcSpan
_ (TransStmt {}) [ExprLStmt GhcTc]
_ = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsDo TransStmt"

dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
    -- In a do expression, pattern-match failure just calls
    -- the monadic 'fail' rather than throwing an exception
dsHandleMonadicFailure :: LPat GhcTc
-> MatchResult CoreExpr -> Maybe (SyntaxExpr GhcTc) -> DsM CoreExpr
dsHandleMonadicFailure LPat GhcTc
pat MatchResult CoreExpr
match Maybe (SyntaxExpr GhcTc)
m_fail_op =
  case MatchResult CoreExpr -> MatchResult CoreExpr
shareFailureHandler MatchResult CoreExpr
match of
    MR_Infallible DsM CoreExpr
body -> DsM CoreExpr
body
    MR_Fallible CoreExpr -> DsM CoreExpr
body -> do
      SyntaxExprTc
fail_op <- case Maybe (SyntaxExpr GhcTc)
m_fail_op of
        -- Note that (non-monadic) list comprehension, pattern guards, etc could
        -- have fallible bindings without an explicit failure op, but this is
        -- handled elsewhere. See Note [Failing pattern matches in Stmts] the
        -- breakdown of regular and special binds.
        Maybe (SyntaxExpr GhcTc)
Nothing -> String -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) SyntaxExprTc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"missing fail op" (SDoc -> IOEnv (Env DsGblEnv DsLclEnv) SyntaxExprTc)
-> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) SyntaxExprTc
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text String
"Pattern match:" SDoc -> SDoc -> SDoc
<+> Located (Pat GhcTc) -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (Pat (GhcPass p))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr Located (Pat GhcTc)
LPat GhcTc
pat SDoc -> SDoc -> SDoc
<+>
          String -> SDoc
text String
"is failable, and fail_expr was left unset"
        Just SyntaxExpr GhcTc
fail_op -> SyntaxExprTc -> IOEnv (Env DsGblEnv DsLclEnv) SyntaxExprTc
forall (f :: * -> *) a. Applicative f => a -> f a
External instance of the constraint type forall m. Applicative (IOEnv m)
pure SyntaxExpr GhcTc
SyntaxExprTc
fail_op
      DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
      CoreExpr
fail_msg <- String -> DsM CoreExpr
forall (m :: * -> *). MonadThings m => String -> m CoreExpr
External instance of the constraint type MonadThings (IOEnv (Env DsGblEnv DsLclEnv))
mkStringExpr (DynFlags -> Located (Pat GhcTc) -> String
forall e. DynFlags -> Located e -> String
mk_fail_msg DynFlags
dflags Located (Pat GhcTc)
LPat GhcTc
pat)
      CoreExpr
fail_expr <- SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
SyntaxExprTc
fail_op [CoreExpr
fail_msg]
      CoreExpr -> DsM CoreExpr
body CoreExpr
fail_expr

mk_fail_msg :: DynFlags -> Located e -> String
mk_fail_msg :: DynFlags -> Located e -> String
mk_fail_msg DynFlags
dflags Located e
pat = String
"Pattern match failure in do expression at " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                         DynFlags -> SrcSpan -> String
forall a. Outputable a => DynFlags -> a -> String
External instance of the constraint type Outputable SrcSpan
showPpr DynFlags
dflags (Located e -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located e
pat)

{-
************************************************************************
*                                                                      *
   Desugaring Variables
*                                                                      *
************************************************************************
-}

dsHsVar :: Id -> DsM CoreExpr
dsHsVar :: Id -> DsM CoreExpr
dsHsVar Id
var
  | let bad_tys :: [Type]
bad_tys = Id -> Type -> [Type]
badUseOfLevPolyPrimop Id
var Type
ty
  , Bool -> Bool
not ([Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [Type]
bad_tys)
  = do { SDoc -> Type -> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) ()
levPolyPrimopErr (Id -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type Outputable Id
ppr Id
var) Type
ty [Type]
bad_tys
       ; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return CoreExpr
unitExpr }  -- return something eminently safe

  | Bool
otherwise
  = CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
var)   -- See Note [Desugaring vars]
  where
    ty :: Type
ty = Id -> Type
idType Id
var

dsConLike :: ConLike -> DsM CoreExpr
dsConLike :: ConLike -> DsM CoreExpr
dsConLike (RealDataCon DataCon
dc) = Id -> DsM CoreExpr
dsHsVar (DataCon -> Id
dataConWrapId DataCon
dc)
dsConLike (PatSynCon PatSyn
ps)   = CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ case PatSyn -> Maybe (Id, Bool)
patSynBuilder PatSyn
ps of
  Just (Id
id, Bool
add_void)
    | Bool
add_void  -> SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp (String -> SDoc
text String
"dsConLike" SDoc -> SDoc -> SDoc
<+> PatSyn -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type Outputable PatSyn
ppr PatSyn
ps) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
id) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
voidPrimId)
    | Bool
otherwise -> Id -> CoreExpr
forall b. Id -> Expr b
Var Id
id
  Maybe (Id, Bool)
_ -> String -> SDoc -> CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsConLike" (PatSyn -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type Outputable PatSyn
ppr PatSyn
ps)

{-
************************************************************************
*                                                                      *
\subsection{Errors and contexts}
*                                                                      *
************************************************************************
-}

-- Warn about certain types of values discarded in monadic bindings (#3263)
warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDiscardedDoBindings LHsExpr GhcTc
rhs Type
rhs_ty
  | Just (Type
m_ty, Type
elt_ty) <- Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
rhs_ty
  = do { Bool
warn_unused <- WarningFlag -> TcRnIf DsGblEnv DsLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnUnusedDoBind
       ; Bool
warn_wrong <- WarningFlag -> TcRnIf DsGblEnv DsLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnWrongDoBind
       ; Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
when (Bool
warn_unused Bool -> Bool -> Bool
|| Bool
warn_wrong) (IOEnv (Env DsGblEnv DsLclEnv) ()
 -> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
    do { FamInstEnvs
fam_inst_envs <- DsM FamInstEnvs
dsGetFamInstEnvs
       ; let norm_elt_ty :: Type
norm_elt_ty = FamInstEnvs -> Type -> Type
topNormaliseType FamInstEnvs
fam_inst_envs Type
elt_ty

           -- Warn about discarding non-() things in 'monadic' binding
       ; if Bool
warn_unused Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isUnitTy Type
norm_elt_ty)
         then WarnReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnusedDoBind)
                     (LHsExpr GhcTc -> Type -> SDoc
badMonadBind LHsExpr GhcTc
rhs Type
elt_ty)
         else

           -- Warn about discarding m a things in 'monadic' binding of the same type,
           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
           Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
External instance of the constraint type forall m. Applicative (IOEnv m)
when Bool
warn_wrong (IOEnv (Env DsGblEnv DsLclEnv) ()
 -> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
                do { case Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
norm_elt_ty of
                         Just (Type
elt_m_ty, Type
_)
                            | Type
m_ty Type -> Type -> Bool
`eqType` FamInstEnvs -> Type -> Type
topNormaliseType FamInstEnvs
fam_inst_envs Type
elt_m_ty
                            -> WarnReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnWrongDoBind)
                                      (LHsExpr GhcTc -> Type -> SDoc
badMonadBind LHsExpr GhcTc
rhs Type
elt_ty)
                         Maybe (Type, Type)
_ -> () -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return () } } }

  | Bool
otherwise   -- RHS does have type of form (m ty), which is weird
  = () -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ()   -- but at least this warning is irrelevant

badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
badMonadBind LHsExpr GhcTc
rhs Type
elt_ty
  = [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"A do-notation statement discarded a result of type")
              Int
2 (SDoc -> SDoc
quotes (Type -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type Outputable Type
ppr Type
elt_ty))
         , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Suppress this warning by saying")
              Int
2 (SDoc -> SDoc
quotes (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"_ <-" SDoc -> SDoc -> SDoc
<+> LHsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
External instance of the constraint type forall l e.
(Outputable l, Outputable e) =>
Outputable (GenLocated l e)
External instance of the constraint type Outputable SrcSpan
External instance of the constraint type forall (p :: Pass).
OutputableBndrId p =>
Outputable (HsExpr (GhcPass p))
External instance of the constraint type OutputableBndr Id
External instance of the constraint type OutputableBndr Name
External instance of the constraint type IsPass 'Typechecked
ppr LHsExpr GhcTc
rhs)
         ]

{-
************************************************************************
*                                                                      *
   Forced eta expansion and levity polymorphism
*                                                                      *
************************************************************************

Note [Detecting forced eta expansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We cannot have levity polymorphic function arguments. See
Note [Levity polymorphism invariants] in GHC.Core. But we *can* have
functions that take levity polymorphic arguments, as long as these
functions are eta-reduced. (See #12708 for an example.)

However, we absolutely cannot do this for functions that have no
binding (i.e., say True to Id.hasNoBinding), like primops and unboxed
tuple constructors. These get eta-expanded in CorePrep.maybeSaturate.

Detecting when this is about to happen is a bit tricky, though. When
the desugarer is looking at the Id itself (let's be concrete and
suppose we have (#,#)), we don't know whether it will be levity
polymorphic. So the right spot seems to be to look after the Id has
been applied to its type arguments. To make the algorithm efficient,
it's important to be able to spot ((#,#) @a @b @c @d) without looking
past all the type arguments. We thus require that
  * The body of an HsWrap is not an HsWrap, nor an HsPar.
This invariant is checked in dsExpr.
With that representation invariant, we simply look inside every HsWrap
to see if its body is an HsVar whose Id hasNoBinding. Then, we look
at the wrapped type. If it has any levity polymorphic arguments, reject.
Because we might have an HsVar without a wrapper, we check in dsHsVar
as well. typecheck/should_fail/T17021 triggers this case.

Interestingly, this approach does not look to see whether the Id in
question will be eta expanded. The logic is this:
  * Either the Id in question is saturated or not.
  * If it is, then it surely can't have levity polymorphic arguments.
    If its wrapped type contains levity polymorphic arguments, reject.
  * If it's not, then it can't be eta expanded with levity polymorphic
    argument. If its wrapped type contains levity polymorphic arguments, reject.
So, either way, we're good to reject.

-}

-- | Takes an expression and its instantiated type. If the expression is an
-- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments,
-- issue an error. See Note [Detecting forced eta expansion]
checkForcedEtaExpansion :: HsExpr GhcTc -> SDoc -> Type -> DsM ()
checkForcedEtaExpansion :: HsExpr GhcTc -> SDoc -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
checkForcedEtaExpansion HsExpr GhcTc
expr SDoc
expr_doc Type
ty
  | Just Id
var <- case HsExpr GhcTc
expr of
                  HsVar XVar GhcTc
_ (L SrcSpan
_ IdP GhcTc
var)               -> Id -> Maybe Id
forall a. a -> Maybe a
Just Id
IdP GhcTc
var
                  HsConLikeOut XConLikeOut GhcTc
_ (RealDataCon DataCon
dc) -> Id -> Maybe Id
forall a. a -> Maybe a
Just (DataCon -> Id
dataConWrapId DataCon
dc)
                  HsExpr GhcTc
_                               -> Maybe Id
forall a. Maybe a
Nothing
  , let bad_tys :: [Type]
bad_tys = Id -> Type -> [Type]
badUseOfLevPolyPrimop Id
var Type
ty
  , Bool -> Bool
not ([Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [Type]
bad_tys)
  = SDoc -> Type -> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) ()
levPolyPrimopErr SDoc
expr_doc Type
ty [Type]
bad_tys
checkForcedEtaExpansion HsExpr GhcTc
_ SDoc
_ Type
_ = () -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ()

-- | Is this a hasNoBinding Id with a levity-polymorphic type?
-- Returns the arguments that are levity polymorphic if they are bad;
-- or an empty list otherwise
-- See Note [Detecting forced eta expansion]
badUseOfLevPolyPrimop :: Id -> Type -> [Type]
badUseOfLevPolyPrimop :: Id -> Type -> [Type]
badUseOfLevPolyPrimop Id
id Type
ty
  | Id -> Bool
hasNoBinding Id
id
  = (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
isTypeLevPoly [Type]
arg_tys
  | Bool
otherwise
  = []
  where
    ([TyCoBinder]
binders, Type
_) = Type -> ([TyCoBinder], Type)
splitPiTys Type
ty
    arg_tys :: [Type]
arg_tys      = (TyCoBinder -> Maybe Type) -> [TyCoBinder] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TyCoBinder -> Maybe Type
binderRelevantType_maybe [TyCoBinder]
binders

levPolyPrimopErr :: SDoc -> Type -> [Type] -> DsM ()
levPolyPrimopErr :: SDoc -> Type -> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) ()
levPolyPrimopErr SDoc
expr_doc Type
ty [Type]
bad_tys
  = SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
errDs (SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ())
-> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
    [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Cannot use function with levity-polymorphic arguments:")
         Int
2 (SDoc
expr_doc SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprWithTYPE Type
ty)
    , (SDocContext -> Bool) -> SDoc -> SDoc
ppUnlessOption SDocContext -> Bool
sdocPrintTypecheckerElaboration (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
        [ String -> SDoc
text String
"(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples"
        , String -> SDoc
text String
"are eta-expanded internally because they must occur fully saturated."
        , String -> SDoc
text String
"Use -fprint-typechecker-elaboration to display the full expression.)"
        ]
    , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Levity-polymorphic arguments:")
         Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Type -> SDoc) -> [Type] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map
           (\Type
t -> Type -> SDoc
pprWithTYPE Type
t SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprWithTYPE (HasDebugCallStack => Type -> Type
Type -> Type
External instance of the constraint type HasDebugCallStack
typeKind Type
t))
           [Type]
bad_tys
    ]