{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE LambdaCase #-}
module GHC.HsToCore.Expr
( dsExpr, dsLExpr, dsLocalBinds
, dsValBinds, dsLit, dsSyntaxExpr
)
where
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.Pmc
import GHC.HsToCore.Pmc.Utils
import GHC.HsToCore.Errors.Types
import GHC.HsToCore.Quote
import GHC.HsToCore.Ticks (stripTicksTopHsExpr)
import GHC.Hs
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
import GHC.Tc.Instance.Class (lookupHasFieldLabel)
import GHC.Core
import GHC.Core.FVs( exprsFreeVarsList )
import GHC.Core.FamInstEnv( topNormaliseType )
import GHC.Core.Type
import GHC.Core.TyCo.Rep
import GHC.Core.Utils
import GHC.Core.Make
import GHC.Core.PatSyn
import GHC.Driver.Session
import GHC.Types.SourceText
import GHC.Types.Name hiding (varName)
import GHC.Types.CostCentre
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Id.Make
import GHC.Types.Var( isInvisibleAnonPiTyBinder )
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Tickish
import GHC.Unit.Module
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import Control.Monad
import qualified Data.Set as S
dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds (EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
_) CoreExpr
body = CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
body
dsLocalBinds b :: HsLocalBinds GhcTc
b@(HsValBinds XHsValBinds GhcTc GhcTc
_ HsValBindsLR GhcTc GhcTc
binds) CoreExpr
body = SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (HsLocalBinds GhcTc -> SrcSpan
forall (p :: Pass). HsLocalBinds (GhcPass p) -> SrcSpan
spanHsLocaLBinds HsLocalBinds GhcTc
b) (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 (HsIPBinds XHsIPBinds GhcTc GhcTc
_ HsIPBinds GhcTc
binds) CoreExpr
body = HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds HsIPBinds GhcTc
binds CoreExpr
body
dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds :: HsValBindsLR GhcTc GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds (XValBindsLR (NValBinds [(RecFlag, LHsBinds GhcTc)]
binds [LSig GhcRn]
_)) CoreExpr
body
= do { dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; foldrM (ds_val_bind dflags) body binds }
dsValBinds (ValBinds {}) CoreExpr
_ = String -> DsM CoreExpr
forall a. HasCallStack => 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 { TcEvBinds -> ([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr
forall a. TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
dsTcEvBinds XIPBinds GhcTc
TcEvBinds
ev_binds (([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr)
-> ([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ \ [CoreBind]
ds_binds -> do
{ let inner :: CoreExpr
inner = [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_binds CoreExpr
body
; (GenLocated SrcSpanAnnA (IPBind GhcTc) -> CoreExpr -> DsM CoreExpr)
-> CoreExpr
-> [GenLocated SrcSpanAnnA (IPBind GhcTc)]
-> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
GenLocated SrcSpanAnnA (IPBind GhcTc) -> CoreExpr -> DsM CoreExpr
ds_ip_bind CoreExpr
inner [LIPBind GhcTc]
[GenLocated SrcSpanAnnA (IPBind GhcTc)]
ip_binds } }
where
ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
ds_ip_bind (L SrcSpanAnnA
_ (IPBind XCIPBind GhcTc
n XRec GhcTc HsIPName
_ LHsExpr GhcTc
e)) CoreExpr
body
= do e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
return (Let (NonRec n e') body)
ds_val_bind :: DynFlags -> (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
ds_val_bind :: DynFlags -> (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
ds_val_bind DynFlags
_ (RecFlag
NonRecursive, LHsBinds GhcTc
hsbinds) CoreExpr
body
| [L SrcSpanAnnA
loc HsBind GhcTc
bind] <- LHsBinds GhcTc
hsbinds
, HsBind GhcTc -> Bool
isUnliftedHsBind HsBind GhcTc
bind
= SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
if HsBind GhcTc -> Bool
forall {idL} {idR}.
(XXHsBindsLR idL idR ~ AbsBinds) =>
HsBindLR idL idR -> Bool
is_polymorphic HsBind GhcTc
bind
then DsMessage -> DsM CoreExpr
errDsCoreExpr (HsBind GhcTc -> DsMessage
DsCannotMixPolyAndUnliftedBindings HsBind GhcTc
bind)
else do { Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HsBind GhcTc -> 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
$
DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs (HsBind GhcTc -> DsMessage
DsUnbangedStrictPatterns HsBind GhcTc
bind)
; HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind HsBind GhcTc
bind CoreExpr
body }
where
is_polymorphic :: HsBindLR idL idR -> Bool
is_polymorphic (XHsBindsLR (AbsBinds { abs_tvs :: AbsBinds -> [EvId]
abs_tvs = [EvId]
tvs, abs_ev_vars :: AbsBinds -> [EvId]
abs_ev_vars = [EvId]
evs }))
= Bool -> Bool
not ([EvId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvId]
tvs Bool -> Bool -> Bool
&& [EvId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvId]
evs)
is_polymorphic HsBindLR idL idR
_ = Bool
False
ds_val_bind DynFlags
_ (RecFlag
is_rec, LHsBinds GhcTc
binds) CoreExpr
_body
| (GenLocated SrcSpanAnnA (HsBind GhcTc) -> Bool)
-> [GenLocated SrcSpanAnnA (HsBind GhcTc)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HsBind GhcTc -> Bool
isUnliftedHsBind (HsBind GhcTc -> Bool)
-> (GenLocated SrcSpanAnnA (HsBind GhcTc) -> HsBind GhcTc)
-> GenLocated SrcSpanAnnA (HsBind GhcTc)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBind GhcTc) -> HsBind GhcTc
forall l e. GenLocated l e -> e
unLoc) LHsBinds GhcTc
[GenLocated SrcSpanAnnA (HsBind GhcTc)]
binds
= Bool -> (DsMessage -> DsM CoreExpr) -> DsMessage -> DsM CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert (RecFlag -> Bool
isRec RecFlag
is_rec )
DsMessage -> DsM CoreExpr
errDsCoreExpr (DsMessage -> DsM CoreExpr) -> DsMessage -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ LHsBinds GhcTc -> DsMessage
DsRecBindsNotAllowedForUnliftedTys LHsBinds GhcTc
binds
ds_val_bind DynFlags
dflags (RecFlag
NonRecursive, LHsBinds GhcTc
hsbinds) CoreExpr
body
| [L SrcSpanAnnA
_loc (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_mult :: forall idL idR. HsBindLR idL idR -> HsMultAnn idL
pat_mult = HsMultAnn GhcTc
mult_ann
, pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = (Type
ty, ([CoreTickish]
rhs_tick, [[CoreTickish]]
_var_ticks))})] <- LHsBinds GhcTc
hsbinds
, LPat GhcTc
pat' <- DynFlags -> LPat GhcTc -> LPat GhcTc
decideBangHood DynFlags
dflags LPat GhcTc
pat
, LPat GhcTc -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
isBangedLPat LPat GhcTc
pat'
= do { rhss_nablas <- HsMatchContextRn
-> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
pmcGRHSs HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
PatBindGuards GRHSs GhcTc (LHsExpr GhcTc)
grhss
; rhs_expr <- dsGuarded grhss ty rhss_nablas
; let rhs' = [CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox [CoreTickish]
rhs_tick CoreExpr
rhs_expr
; let body_ty = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body
; let mult = HsMultAnn GhcTc -> Type
getTcMultAnn HsMultAnn GhcTc
mult_ann
; error_expr <- mkErrorAppDs pAT_ERROR_ID body_ty (ppr pat')
; matchSimply rhs' PatBindRhs mult pat' body error_expr }
ds_val_bind DynFlags
_ (RecFlag
is_rec, LHsBinds GhcTc
binds) CoreExpr
body
= do { Bool -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (RecFlag -> Bool
isRec RecFlag
is_rec Bool -> Bool -> Bool
|| [GenLocated SrcSpanAnnA (HsBind GhcTc)] -> Bool
forall a. [a] -> Bool
isSingleton LHsBinds GhcTc
[GenLocated SrcSpanAnnA (HsBind GhcTc)]
binds)
; (force_vars,prs) <- LHsBinds GhcTc -> DsM ([EvId], [(EvId, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
; let body' = (EvId -> CoreExpr -> CoreExpr) -> CoreExpr -> [EvId] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr EvId -> CoreExpr -> CoreExpr
seqVar CoreExpr
body [EvId]
force_vars
; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $
case prs of
[] -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
body
[(EvId, CoreExpr)]
_ -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreBind] -> CoreExpr -> CoreExpr
forall b. [Bind b] -> Expr b -> Expr b
mkLets (RecFlag -> [(EvId, CoreExpr)] -> [CoreBind]
forall b. RecFlag -> [(b, Expr b)] -> [Bind b]
mk_binds RecFlag
is_rec [(EvId, CoreExpr)]
prs) CoreExpr
body') }
mk_binds :: RecFlag -> [(b, (Expr b))] -> [Bind b]
mk_binds :: forall b. RecFlag -> [(b, Expr b)] -> [Bind b]
mk_binds RecFlag
Recursive [(b, Expr b)]
binds = [[(b, Expr b)] -> Bind b
forall b. [(b, Expr b)] -> Bind b
Rec [(b, Expr b)]
binds]
mk_binds RecFlag
NonRecursive [(b, Expr b)]
binds = ((b, Expr b) -> Bind b) -> [(b, Expr b)] -> [Bind b]
forall a b. (a -> b) -> [a] -> [b]
map ((b -> Expr b -> Bind b) -> (b, Expr b) -> Bind b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry b -> Expr b -> Bind b
forall b. b -> Expr b -> Bind b
NonRec) [(b, Expr b)]
binds
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (XHsBindsLR (AbsBinds { abs_tvs :: AbsBinds -> [EvId]
abs_tvs = [], abs_ev_vars :: AbsBinds -> [EvId]
abs_ev_vars = []
, abs_exports :: AbsBinds -> [ABExport]
abs_exports = [ABExport]
exports
, abs_ev_binds :: AbsBinds -> [TcEvBinds]
abs_ev_binds = [TcEvBinds]
ev_binds
, abs_binds :: AbsBinds -> LHsBinds GhcTc
abs_binds = LHsBinds GhcTc
lbinds })) CoreExpr
body
= do { let body1 :: CoreExpr
body1 = (ABExport -> CoreExpr -> CoreExpr)
-> CoreExpr -> [ABExport] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ABExport -> CoreExpr -> CoreExpr
bind_export CoreExpr
body [ABExport]
exports
bind_export :: ABExport -> CoreExpr -> CoreExpr
bind_export ABExport
export CoreExpr
b = HasDebugCallStack => EvId -> CoreExpr -> CoreExpr -> CoreExpr
EvId -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec (ABExport -> EvId
abe_poly ABExport
export) (EvId -> CoreExpr
forall b. EvId -> Expr b
Var (ABExport -> EvId
abe_mono ABExport
export)) CoreExpr
b
; body2 <- (CoreExpr -> GenLocated SrcSpanAnnA (HsBind GhcTc) -> DsM CoreExpr)
-> CoreExpr
-> [GenLocated SrcSpanAnnA (HsBind GhcTc)]
-> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\CoreExpr
body GenLocated SrcSpanAnnA (HsBind GhcTc)
lbind -> HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (GenLocated SrcSpanAnnA (HsBind GhcTc) -> HsBind GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsBind GhcTc)
lbind) CoreExpr
body)
CoreExpr
body1 LHsBinds GhcTc
[GenLocated SrcSpanAnnA (HsBind GhcTc)]
lbinds
; dsTcEvBinds_s ev_binds $ \ [CoreBind]
ds_binds -> do
{ CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_binds CoreExpr
body2) } }
dsUnliftedBind (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
l EvId
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 = (HsWrapper
co_fn, [CoreTickish]
tick)
}) CoreExpr
body
= do { (args, rhs) <- HsMatchContextRn
-> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([EvId], CoreExpr)
matchWrapper (GenLocated SrcSpanAnnN Name
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
l (Name -> GenLocated SrcSpanAnnN Name)
-> Name -> GenLocated SrcSpanAnnN Name
forall a b. (a -> b) -> a -> b
$ EvId -> Name
idName EvId
fun) AnnFunRhs
forall a. NoAnn a => a
noAnn) Maybe [LHsExpr GhcTc]
Maybe [LocatedA (HsExpr GhcTc)]
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
; massert (null args)
; dsHsWrapper co_fn $ \CoreExpr -> CoreExpr
core_wrap ->
do { let rhs' :: CoreExpr
rhs' = CoreExpr -> CoreExpr
core_wrap ([CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox [CoreTickish]
tick CoreExpr
rhs)
; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => EvId -> CoreExpr -> CoreExpr -> CoreExpr
EvId -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec EvId
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 = (Type
ty, ([CoreTickish], [[CoreTickish]])
_) }) CoreExpr
body
=
do { match_nablas <- HsMatchContextRn
-> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
pmcGRHSs HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
PatBindGuards GRHSs GhcTc (LHsExpr GhcTc)
grhss
; rhs <- dsGuarded grhss ty match_nablas
; let eqn = EqnMatch { eqn_pat :: LPat GhcTc
eqn_pat = LPat GhcTc
pat, eqn_rest :: EquationInfo
eqn_rest = MatchResult CoreExpr -> EquationInfo
EqnDone (CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
body) }
; var <- selectMatchVar ManyTy (unLoc pat)
; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
; return (bindNonRec var rhs 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
ppr HsBind GhcTc
bind SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
body)
dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (L SrcSpanAnnA
loc HsExpr GhcTc
e) = SrcSpanAnnA -> DsM CoreExpr -> DsM CoreExpr
forall ann a. EpAnn ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
e
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsExpr e :: HsExpr GhcTc
e@(HsVar {}) = HsExpr GhcTc -> DsM CoreExpr
dsApp HsExpr GhcTc
e
dsExpr e :: HsExpr GhcTc
e@(HsApp {}) = HsExpr GhcTc -> DsM CoreExpr
dsApp HsExpr GhcTc
e
dsExpr e :: HsExpr GhcTc
e@(HsAppType {}) = HsExpr GhcTc -> DsM CoreExpr
dsApp HsExpr GhcTc
e
dsExpr (HsUnboundVar (HER IORef EvTerm
ref Type
_ Unique
_) RdrName
_) = EvTerm -> DsM CoreExpr
dsEvTerm (EvTerm -> DsM CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) EvTerm -> DsM CoreExpr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef EvTerm -> IOEnv (Env DsGblEnv DsLclEnv) EvTerm
forall a env. IORef a -> IOEnv env a
readMutVar IORef EvTerm
ref
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 (HsLit XLitE GhcTc
_ HsLit GhcTc
lit)
= do { HsLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedLit HsLit GhcTc
lit
; HsLit GhcTc -> DsM CoreExpr
forall (p :: Pass). IsPass p => HsLit (GhcPass p) -> DsM CoreExpr
dsLit 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 e :: HsExpr GhcTc
e@(XExpr XXExpr GhcTc
ext_expr_tc)
= case XXExpr GhcTc
ext_expr_tc of
HsRecSelTc {} -> HsExpr GhcTc -> DsM CoreExpr
dsApp HsExpr GhcTc
e
WrapExpr {} -> HsExpr GhcTc -> DsM CoreExpr
dsApp HsExpr GhcTc
e
ConLikeTc {} -> HsExpr GhcTc -> DsM CoreExpr
dsApp HsExpr GhcTc
e
ExpandedThingTc HsThingRn
o HsExpr GhcTc
e
| OrigStmt (L SrcSpanAnnA
loc StmtLR GhcRn GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
_) <- HsThingRn
o
-> SrcSpanAnnA -> DsM CoreExpr -> DsM CoreExpr
forall ann a. EpAnn ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
e
| Bool
otherwise -> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
e
HsTick CoreTickish
tickish LHsExpr GhcTc
e -> do
e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
return (Tick tickish e')
HsBinTick Int
ixT Int
ixF LHsExpr GhcTc
e -> do
e2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
do { assert (exprType e2 `eqType` boolTy)
mkBinaryTickBox ixT ixF e2
}
dsExpr (NegApp XNegApp GhcTc
_ (L SrcSpanAnnA
loc
(HsExpr GhcTc -> ([CoreTickish], HsExpr GhcTc)
stripTicksTopHsExpr -> ([CoreTickish]
ts, (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 { expr' <- SrcSpanAnnA -> DsM CoreExpr -> DsM CoreExpr
forall ann a. EpAnn ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
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 = HsIntegral (negateIntegralLit i) })
; HsOverLit GhcTc -> DsM CoreExpr
dsOverLit HsOverLit GhcTc
lit }
; dsSyntaxExpr neg_expr [mkTicks ts expr'] }
dsExpr (NegApp XNegApp GhcTc
_ LHsExpr GhcTc
expr SyntaxExpr GhcTc
neg_expr)
= do { expr' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
; dsSyntaxExpr neg_expr [expr'] }
dsExpr (HsLam XLam GhcTc
_ HsLamVariant
variant MatchGroup GhcTc (LHsExpr GhcTc)
a_Match)
= ([EvId] -> CoreExpr -> CoreExpr) -> ([EvId], CoreExpr) -> CoreExpr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [EvId] -> CoreExpr -> CoreExpr
mkCoreLams (([EvId], CoreExpr) -> CoreExpr)
-> DsM ([EvId], CoreExpr) -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsMatchContextRn
-> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([EvId], CoreExpr)
matchWrapper (HsLamVariant -> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsLamVariant -> HsMatchContext fn
LamAlt HsLamVariant
variant) Maybe [LHsExpr GhcTc]
Maybe [LocatedA (HsExpr GhcTc)]
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
a_Match
dsExpr (ExplicitTuple XExplicitTuple GhcTc
_ [HsTupArg GhcTc]
tup_args Boxity
boxity)
= do { let go :: ([EvId], [CoreExpr])
-> HsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([EvId], [CoreExpr])
go ([EvId]
lam_vars, [CoreExpr]
args) (Missing XMissing GhcTc
st)
= do { lam_var <- Scaled Type -> DsM EvId
newSysLocalDs XMissing GhcTc
Scaled Type
st
; return (lam_var : lam_vars, Var lam_var : args) }
go ([EvId]
lam_vars, [CoreExpr]
args) (Present XPresent GhcTc
_ LHsExpr GhcTc
expr)
= do { core_expr <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
; return (lam_vars, core_expr : args) }
; (lam_vars, args) <- (([EvId], [CoreExpr])
-> HsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([EvId], [CoreExpr]))
-> ([EvId], [CoreExpr])
-> [HsTupArg GhcTc]
-> IOEnv (Env DsGblEnv DsLclEnv) ([EvId], [CoreExpr])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([EvId], [CoreExpr])
-> HsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([EvId], [CoreExpr])
go ([], []) ([HsTupArg GhcTc] -> [HsTupArg GhcTc]
forall a. [a] -> [a]
reverse [HsTupArg GhcTc]
tup_args)
; return $ mkCoreLams lam_vars (mkCoreTupBoxity boxity args) }
dsExpr (ExplicitSum XExplicitSum GhcTc
types Int
alt Int
arity LHsExpr GhcTc
expr)
= Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUnboxedSum Int
arity Int
alt [Type]
XExplicitSum GhcTc
types (CoreExpr -> CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
dsExpr (HsPragE XPragE GhcTc
_ (HsPragSCC XSCC GhcTc
_ StringLiteral
cc) LHsExpr GhcTc
expr)
= do { dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags
then do
mod_name <- getModule
count <- goptM Opt_ProfCountEntries
let nm = StringLiteral -> FastString
sl_fs StringLiteral
cc
flavour <- mkExprCCFlavour <$> getCCIndexDsM nm
Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True)
<$> dsLExpr expr
else dsLExpr expr }
dsExpr (HsCase XCase GhcTc
ctxt LHsExpr GhcTc
discrim MatchGroup GhcTc (LHsExpr GhcTc)
matches)
= do { core_discrim <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
discrim
; ([discrim_var], matching_code) <- matchWrapper ctxt (Just [discrim]) matches
; return (bindNonRec discrim_var core_discrim matching_code) }
dsExpr (HsLet XLet GhcTc
_ HsLocalBinds GhcTc
binds LHsExpr GhcTc
body) = do
body' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
body
dsLocalBinds binds body'
dsExpr (HsDo XDo GhcTc
res_ty HsDoFlavour
ListComp (L SrcSpanAnnLW
_ [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)) = [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
dsListComp [ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts XDo GhcTc
Type
res_ty
dsExpr (HsDo XDo GhcTc
_ HsDoFlavour
MonadComp (L SrcSpanAnnLW
_ [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)) = [ExprLStmt GhcTc] -> DsM CoreExpr
dsMonadComp [ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
dsExpr (HsDo XDo GhcTc
res_ty ctx :: HsDoFlavour
ctx@DoExpr{} (L SrcSpanAnnLW
_ [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)) = HsDoFlavour -> [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
dsDo HsDoFlavour
ctx [ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts XDo GhcTc
Type
res_ty
dsExpr (HsDo XDo GhcTc
res_ty ctx :: HsDoFlavour
ctx@HsDoFlavour
GhciStmtCtxt (L SrcSpanAnnLW
_ [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)) = HsDoFlavour -> [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
dsDo HsDoFlavour
ctx [ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts XDo GhcTc
Type
res_ty
dsExpr (HsDo XDo GhcTc
res_ty ctx :: HsDoFlavour
ctx@MDoExpr{} (L SrcSpanAnnLW
_ [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)) = HsDoFlavour -> [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
dsDo HsDoFlavour
ctx [ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts XDo GhcTc
Type
res_ty
dsExpr (HsIf XIf GhcTc
_ LHsExpr GhcTc
guard_expr LHsExpr GhcTc
then_expr LHsExpr GhcTc
else_expr)
= do { pred <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
guard_expr
; b1 <- dsLExpr then_expr
; b2 <- dsLExpr else_expr
; return $ mkIfThenElse pred b1 b2 }
dsExpr (HsMultiIf XMultiIf GhcTc
res_ty [LGRHS GhcTc (LHsExpr GhcTc)]
alts)
| [GenLocated
(EpAnn NoEpAnns) (GRHS GhcTc (LocatedA (HsExpr GhcTc)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LGRHS GhcTc (LHsExpr GhcTc)]
[GenLocated
(EpAnn NoEpAnns) (GRHS GhcTc (LocatedA (HsExpr GhcTc)))]
alts
= DsM CoreExpr
mkErrorExpr
| Bool
otherwise
= do { let grhss :: GRHSs GhcTc (LocatedA (HsExpr GhcTc))
grhss = XCGRHSs GhcTc (LocatedA (HsExpr GhcTc))
-> [LGRHS GhcTc (LocatedA (HsExpr GhcTc))]
-> HsLocalBinds GhcTc
-> GRHSs GhcTc (LocatedA (HsExpr GhcTc))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTc (LocatedA (HsExpr GhcTc))
EpAnnComments
emptyComments [LGRHS GhcTc (LHsExpr GhcTc)]
[LGRHS GhcTc (LocatedA (HsExpr GhcTc))]
alts HsLocalBinds GhcTc
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds
; rhss_nablas <- HsMatchContextRn
-> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
pmcGRHSs HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
IfAlt GRHSs GhcTc (LHsExpr GhcTc)
GRHSs GhcTc (LocatedA (HsExpr GhcTc))
grhss
; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas
; error_expr <- mkErrorExpr
; extractMatchResult match_result error_expr }
where
mkErrorExpr :: DsM CoreExpr
mkErrorExpr = EvId -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs EvId
nON_EXHAUSTIVE_GUARDS_ERROR_ID XMultiIf GhcTc
Type
res_ty
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"multi-way if")
dsExpr (ExplicitList XExplicitList GhcTc
elt_ty [LHsExpr GhcTc]
xs) = Type -> [LHsExpr GhcTc] -> DsM CoreExpr
dsExplicitList XExplicitList GhcTc
Type
elt_ty [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 { newArithSeq <- HsExpr GhcTc -> ArithSeqInfo GhcTc -> DsM CoreExpr
dsArithSeq XArithSeq GhcTc
HsExpr GhcTc
expr ArithSeqInfo GhcTc
seq
; dsSyntaxExpr fl [newArithSeq] }
dsExpr (HsStatic (NameSet
_, Type
whole_ty) expr :: LHsExpr GhcTc
expr@(L SrcSpanAnnA
loc HsExpr GhcTc
_))
= do { expr_ds <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
; let (_, [ty]) = splitTyConApp whole_ty
; makeStaticId <- dsLookupGlobalId makeStaticName
; dflags <- getDynFlags
; let platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
(line, col) = case locA 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] -> CoreExpr
mkCoreTup [ Platform -> Int -> CoreExpr
mkIntExprInt Platform
platform Int
line
, Platform -> Int -> CoreExpr
mkIntExprInt Platform
platform Int
col
]
; putSrcSpanDsA loc $ return $
mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] }
dsExpr (RecordCon { rcon_con :: forall p. HsExpr p -> XRec p (ConLikeP p)
rcon_con = L SrcSpanAnnN
_ ConLike
con_like
, rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcTc
rbinds
, rcon_ext :: forall p. HsExpr p -> XRecordCon p
rcon_ext = XRecordCon GhcTc
con_expr })
= do { con_expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr XRecordCon GhcTc
HsExpr GhcTc
con_expr
; let
(arg_tys, _) = tcSplitFunTys (exprType con_expr')
mk_arg (Type
arg_ty, FieldLabel
fl)
= case [LHsRecField GhcTc (LocatedA (HsExpr GhcTc))]
-> Name -> [LocatedA (HsExpr GhcTc)]
forall arg. [LHsRecField GhcTc arg] -> Name -> [arg]
findField (HsRecFields GhcTc (LocatedA (HsExpr GhcTc))
-> [LHsRecField GhcTc (LocatedA (HsExpr GhcTc))]
forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds HsRecordBinds GhcTc
HsRecFields GhcTc (LocatedA (HsExpr GhcTc))
rbinds) (FieldLabel -> Name
flSelector FieldLabel
fl) of
(LocatedA (HsExpr GhcTc)
rhs:[LocatedA (HsExpr GhcTc)]
rhss) -> Bool
-> (LocatedA (HsExpr GhcTc) -> DsM CoreExpr)
-> LocatedA (HsExpr GhcTc)
-> DsM CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert ([LocatedA (HsExpr GhcTc)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocatedA (HsExpr GhcTc)]
rhss)
LHsExpr GhcTc -> DsM CoreExpr
LocatedA (HsExpr GhcTc) -> DsM CoreExpr
dsLExpr LocatedA (HsExpr GhcTc)
rhs
[] -> EvId -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs EvId
rEC_CON_ERROR_ID Type
arg_ty (FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl))
unlabelled_bottom Type
arg_ty = EvId -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs EvId
rEC_CON_ERROR_ID Type
arg_ty SDoc
forall doc. IsOutput doc => doc
Outputable.empty
labels = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con_like
; con_args <- if null labels
then mapM unlabelled_bottom (map scaledThing arg_tys)
else mapM mk_arg (zipEqual "dsExpr:RecordCon" (map scaledThing arg_tys) labels)
; return (mkCoreApps con_expr' con_args) }
dsExpr (HsTypedBracket XTypedBracket GhcTc
bracket_tc LHsExpr GhcTc
_) = HsBracketTc -> DsM CoreExpr
dsBracket XTypedBracket GhcTc
HsBracketTc
bracket_tc
dsExpr (HsUntypedBracket XUntypedBracket GhcTc
bracket_tc HsQuote GhcTc
_) = HsBracketTc -> DsM CoreExpr
dsBracket XUntypedBracket GhcTc
HsBracketTc
bracket_tc
dsExpr (HsTypedSplice XTypedSplice GhcTc
_ LHsExpr GhcTc
s) = String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsExpr:typed splice" (Maybe Name -> LHsExpr GhcTc -> SDoc
forall (p :: Pass).
OutputableBndrId p =>
Maybe Name -> LHsExpr (GhcPass p) -> SDoc
pprTypedSplice Maybe Name
forall a. Maybe a
Nothing LHsExpr GhcTc
s)
dsExpr (HsUntypedSplice XUntypedSplice GhcTc
ext HsUntypedSplice GhcTc
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XUntypedSplice GhcTc
DataConCantHappen
ext
dsExpr (HsProc XProc GhcTc
_ LPat GhcTc
pat LHsCmdTop GhcTc
cmd) = LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr
dsProcExpr LPat GhcTc
pat LHsCmdTop GhcTc
cmd
dsExpr (HsIPVar XIPVar GhcTc
x HsIPName
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XIPVar GhcTc
DataConCantHappen
x
dsExpr (HsGetField XGetField GhcTc
x LHsExpr GhcTc
_ XRec GhcTc (DotFieldOcc GhcTc)
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XGetField GhcTc
DataConCantHappen
x
dsExpr (HsProjection XProjection GhcTc
x NonEmpty (DotFieldOcc GhcTc)
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XProjection GhcTc
DataConCantHappen
x
dsExpr (RecordUpd XRecordUpd GhcTc
x LHsExpr GhcTc
_ LHsRecUpdFields GhcTc
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XRecordUpd GhcTc
DataConCantHappen
x
dsExpr (HsEmbTy XEmbTy GhcTc
x LHsWcType (NoGhcTc GhcTc)
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XEmbTy GhcTc
DataConCantHappen
x
dsExpr (HsQual XQual GhcTc
x XRec GhcTc [LHsExpr GhcTc]
_ LHsExpr GhcTc
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XQual GhcTc
DataConCantHappen
x
dsExpr (HsForAll XForAll GhcTc
x HsForAllTelescope GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XForAll GhcTc
DataConCantHappen
x
dsExpr (HsFunArr XFunArr GhcTc
x HsArrowOf (LHsExpr GhcTc) GhcTc
_ LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XFunArr GhcTc
DataConCantHappen
x
dsExpr (HsOverLabel XOverLabel GhcTc
x FastString
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XOverLabel GhcTc
DataConCantHappen
x
dsExpr (OpApp XOpApp GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XOpApp GhcTc
DataConCantHappen
x
dsExpr (SectionL XSectionL GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XSectionL GhcTc
DataConCantHappen
x
dsExpr (SectionR XSectionR GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen XSectionR GhcTc
DataConCantHappen
x
dsApp :: HsExpr GhcTc -> DsM CoreExpr
dsApp :: HsExpr GhcTc -> DsM CoreExpr
dsApp HsExpr GhcTc
e = HsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
ds_app HsExpr GhcTc
e [] []
ds_lapp :: LHsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
ds_lapp :: LHsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
ds_lapp (L SrcSpanAnnA
loc HsExpr GhcTc
e) [LHsExpr GhcTc]
hs_args [CoreExpr]
core_args
= SrcSpanAnnA -> DsM CoreExpr -> DsM CoreExpr
forall ann a. EpAnn ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
HsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
ds_app HsExpr GhcTc
e [LHsExpr GhcTc]
hs_args [CoreExpr]
core_args
ds_app :: HsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
ds_app :: HsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
ds_app (HsPar XPar GhcTc
_ LHsExpr GhcTc
e) [LHsExpr GhcTc]
hs_args [CoreExpr]
core_args = LHsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
ds_lapp LHsExpr GhcTc
e [LHsExpr GhcTc]
hs_args [CoreExpr]
core_args
ds_app (HsApp XApp GhcTc
_ LHsExpr GhcTc
fun LHsExpr GhcTc
arg) [LHsExpr GhcTc]
hs_args [CoreExpr]
core_args
= do { core_arg <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
arg
; ds_lapp fun (arg : hs_args) (core_arg : core_args) }
ds_app (HsAppType XAppTypeE GhcTc
arg_ty LHsExpr GhcTc
fun LHsWcType (NoGhcTc GhcTc)
_) [LHsExpr GhcTc]
hs_args [CoreExpr]
core_args
= LHsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
ds_lapp LHsExpr GhcTc
fun [LHsExpr GhcTc]
hs_args (Type -> CoreExpr
forall b. Type -> Expr b
Type XAppTypeE GhcTc
Type
arg_ty CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
core_args)
ds_app (XExpr (WrapExpr HsWrapper
hs_wrap HsExpr GhcTc
fun)) [LHsExpr GhcTc]
hs_args [CoreExpr]
core_args
= do { (fun_wrap, all_args) <- HsWrapper -> [CoreExpr] -> DsM (HsWrapper, [CoreExpr])
splitHsWrapperArgs HsWrapper
hs_wrap [CoreExpr]
core_args
; if isIdHsWrapper fun_wrap
then ds_app fun hs_args all_args
else do { core_fun <- dsHsWrapper fun_wrap $ \CoreExpr -> CoreExpr
core_wrap ->
do { core_fun <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
fun
; return (core_wrap core_fun) }
; return (mkCoreApps core_fun all_args) } }
ds_app (XExpr (ConLikeTc ConLike
con [EvId]
tvs [Scaled Type]
tys)) [LHsExpr GhcTc]
_hs_args [CoreExpr]
core_args
= do { ds_con <- ConLike -> DsM CoreExpr
dsHsConLike ConLike
con
; ids <- newSysLocalsDs tys
; let core_fun = [EvId] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvId]
tvs (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ [EvId] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvId]
ids (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr
ds_con CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` [EvId] -> [Type]
mkTyVarTys [EvId]
tvs
CoreExpr -> [EvId] -> CoreExpr
forall b. Expr b -> [EvId] -> Expr b
`mkVarApps` [EvId]
ids
; return (mkApps core_fun core_args) }
ds_app (XExpr (HsRecSelTc (FieldOcc { foLabel :: forall pass. FieldOcc pass -> LIdP pass
foLabel = L SrcSpanAnnN
_ EvId
sel_id }))) [LHsExpr GhcTc]
_hs_args [CoreExpr]
core_args
= EvId -> EvId -> [CoreExpr] -> DsM CoreExpr
ds_app_rec_sel EvId
sel_id EvId
sel_id [CoreExpr]
core_args
ds_app (HsVar XVar GhcTc
_ LIdP GhcTc
lfun) [LHsExpr GhcTc]
hs_args [CoreExpr]
core_args
= do { String -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
tracePm String
"ds_app" (GenLocated SrcSpanAnnN EvId -> SDoc
forall a. Outputable a => a -> SDoc
ppr LIdP GhcTc
GenLocated SrcSpanAnnN EvId
lfun SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
core_args)
; GenLocated SrcSpanAnnN EvId
-> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
ds_app_var LIdP GhcTc
GenLocated SrcSpanAnnN EvId
lfun [LHsExpr GhcTc]
hs_args [CoreExpr]
core_args }
ds_app HsExpr GhcTc
e [LHsExpr GhcTc]
_hs_args [CoreExpr]
core_args
= do { core_e <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
e
; return (mkCoreApps core_e core_args) }
ds_app_var :: LocatedN Id -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
ds_app_var :: GenLocated SrcSpanAnnN EvId
-> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
ds_app_var (L SrcSpanAnnN
loc EvId
fun_id) [LHsExpr GhcTc]
hs_args [CoreExpr]
core_args
| EvId
fun_id EvId -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
getFieldClassOpKey
= do {
fam_inst_envs <- DsM FamInstEnvs
dsGetFamInstEnvs
; rdr_env <- dsGetGlobalRdrEnv
; let core_arg_tys :: [Type] = [ty | Type ty <- core_args]
; case lookupHasFieldLabel fam_inst_envs rdr_env core_arg_tys of
Just (Name
sel_name,GlobalRdrElt
_,Type
_,Type
_)
-> do { sel_id <- Name -> DsM EvId
dsLookupGlobalId Name
sel_name
; tracePm "getfield2" (ppr sel_id)
; ds_app_rec_sel sel_id fun_id core_args }
Maybe (Name, GlobalRdrElt, Type, Type)
_ -> EvId -> [CoreExpr] -> DsM CoreExpr
ds_app_finish EvId
fun_id [CoreExpr]
core_args }
| EvId -> Name
idName EvId
fun_id Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
numericConversionNames
, let (Type
conv_ty, [CoreExpr]
_) = EvId -> [CoreExpr] -> (Type, [CoreExpr])
apply_invis_args EvId
fun_id [CoreExpr]
core_args
, Just (Type
arg_ty, Type
res_ty) <- Type -> Maybe (Type, Type)
splitVisibleFunTy_maybe Type
conv_ty
= do { dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; when (wopt Opt_WarnIdentities dflags
&& arg_ty `eqType` res_ty) $
diagnosticDs (DsIdentitiesFound fun_id conv_ty)
; ds_app_finish fun_id core_args }
| EvId
fun_id EvId -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
thenMClassOpKey
, Type Type
m_ty : CoreExpr
_dict : Type Type
arg_ty : [CoreExpr]
_ <- [CoreExpr]
core_args
, LHsExpr GhcTc
hs_arg : [LHsExpr GhcTc]
_ <- [LHsExpr GhcTc]
hs_args
= do { String -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
tracePm String
">>" (SrcSpanAnnN -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanAnnN
loc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> Bool
isGeneratedSrcSpan (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
loc)))
; Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SrcSpan -> Bool
isGeneratedSrcSpan (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
loc)) (IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcTc -> Type -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDiscardedDoBindings LHsExpr GhcTc
hs_arg Type
m_ty Type
arg_ty
; EvId -> [CoreExpr] -> DsM CoreExpr
ds_app_finish EvId
fun_id [CoreExpr]
core_args }
| EvId
fun_id EvId -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
noinlineIdKey
, Type Type
_ : CoreExpr
arg1 : [CoreExpr]
rest_args <- [CoreExpr]
core_args
, (CoreExpr
inner_fun, [CoreExpr]
inner_args) <- CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
arg1
= CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvId -> CoreExpr
forall b. EvId -> Expr b
Var EvId
fun_id CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Type -> CoreExpr
forall b. Type -> Expr b
Type (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
inner_fun) CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
inner_fun
CoreExpr -> [CoreExpr] -> CoreExpr
`mkCoreApps` [CoreExpr]
inner_args CoreExpr -> [CoreExpr] -> CoreExpr
`mkCoreApps` [CoreExpr]
rest_args)
| EvId
fun_id EvId -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
seqIdKey
, Type Type
_r : Type Type
ty1 : Type Type
ty2 : CoreExpr
arg1 : CoreExpr
arg2 : [CoreExpr]
rest_args <- [CoreExpr]
core_args
, let case_bndr :: EvId
case_bndr = case CoreExpr
arg1 of
Var EvId
v1 | Name -> Bool
isInternalName (EvId -> Name
idName EvId
v1)
-> EvId
v1
CoreExpr
_ -> Type -> Type -> EvId
mkWildValBinder Type
ManyTy Type
ty1
= CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> EvId -> Type -> [Alt EvId] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg1 EvId
case_bndr Type
ty2 [AltCon -> [EvId] -> CoreExpr -> Alt EvId
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
arg2]
CoreExpr -> [CoreExpr] -> CoreExpr
`mkCoreApps` [CoreExpr]
rest_args)
| Bool
otherwise
= EvId -> [CoreExpr] -> DsM CoreExpr
ds_app_finish EvId
fun_id [CoreExpr]
core_args
ds_app_finish :: Id -> [CoreExpr] -> DsM CoreExpr
ds_app_finish :: EvId -> [CoreExpr] -> DsM CoreExpr
ds_app_finish EvId
fun_id [CoreExpr]
core_args
= do { unspecables <- DsM (Set EvId)
getUnspecables
; let fun_ty = EvId -> Type
idType EvId
fun_id
free_dicts = [CoreExpr] -> [EvId]
exprsFreeVarsList
[ CoreExpr
e | (CoreExpr
e,PiTyBinder
pi_bndr) <- [CoreExpr]
core_args [CoreExpr] -> [PiTyBinder] -> [(CoreExpr, PiTyBinder)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` ([PiTyBinder], Type) -> [PiTyBinder]
forall a b. (a, b) -> a
fst (Type -> ([PiTyBinder], Type)
splitPiTys Type
fun_ty)
, PiTyBinder -> Bool
isInvisibleAnonPiTyBinder PiTyBinder
pi_bndr ]
is_unspecable_var EvId
v = EvId
v EvId -> Set EvId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set EvId
unspecables
fun | Bool -> Bool
not (Set EvId -> Bool
forall a. Set a -> Bool
S.null Set EvId
unspecables)
, (EvId -> Bool) -> [EvId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (EvId -> Bool
is_unspecable_var) [EvId]
free_dicts
= EvId -> CoreExpr
forall b. EvId -> Expr b
Var EvId
nospecId CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` Type -> CoreExpr
forall b. Type -> Expr b
Type Type
fun_ty CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` EvId -> CoreExpr
forall b. EvId -> Expr b
Var EvId
fun_id
| Bool
otherwise
= EvId -> CoreExpr
forall b. EvId -> Expr b
Var EvId
fun_id
; return (mkCoreApps fun core_args) }
ds_app_rec_sel :: Id
-> Id
-> [CoreExpr]
-> DsM CoreExpr
ds_app_rec_sel :: EvId -> EvId -> [CoreExpr] -> DsM CoreExpr
ds_app_rec_sel EvId
sel_id EvId
fun_id [CoreExpr]
core_args
| RecSelId{ sel_cons :: IdDetails -> RecSelInfo
sel_cons = RecSelInfo
rec_sel_info } <- EvId -> IdDetails
idDetails EvId
sel_id
, RSI { rsi_undef :: RecSelInfo -> [ConLike]
rsi_undef = [ConLike]
cons_wo_field } <- RecSelInfo
rec_sel_info
= do {
; let (Type
fun_ty, [CoreExpr]
val_args) = EvId -> [CoreExpr] -> (Type, [CoreExpr])
apply_invis_args EvId
fun_id [CoreExpr]
core_args
; String -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
tracePm String
"ds_app_rec_sel" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
val_args)
; case [CoreExpr]
val_args of
(CoreExpr
arg:[CoreExpr]
_) -> EvId -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) ()
pmcRecSel EvId
sel_id CoreExpr
arg
[] | Just (Type
val_arg_ty, Type
_) <- Type -> Maybe (Type, Type)
splitVisibleFunTy_maybe Type
fun_ty
-> do { dummy <- Scaled Type -> DsM EvId
newSysLocalDs (Type -> Type -> Scaled Type
forall a. Type -> a -> Scaled a
Scaled Type
ManyTy Type
val_arg_ty)
; pmcRecSel sel_id (Var dummy) }
[CoreExpr]
_ -> Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ConLike] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConLike]
cons_wo_field) (IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
do { dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let maxCons = DynFlags -> Int
maxUncoveredPatterns DynFlags
dflags
; diagnosticDs $ DsIncompleteRecordSelector (idName sel_id) cons_wo_field maxCons }
; EvId -> [CoreExpr] -> DsM CoreExpr
ds_app_finish EvId
fun_id [CoreExpr]
core_args }
| Bool
otherwise
= String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"ds_app_rec_sel" (EvId -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvId
sel_id SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ IdDetails -> SDoc
forall a. Outputable a => a -> SDoc
ppr (EvId -> IdDetails
idDetails EvId
sel_id))
where
apply_invis_args :: Id -> [CoreExpr] -> (Type, [CoreExpr])
apply_invis_args :: EvId -> [CoreExpr] -> (Type, [CoreExpr])
apply_invis_args EvId
fun_id [CoreExpr]
args
= (HasDebugCallStack => Type -> [CoreExpr] -> Type
Type -> [CoreExpr] -> Type
applyTypeToArgs Type
fun_ty [CoreExpr]
invis_args, [CoreExpr]
rest_args)
where
fun_ty :: Type
fun_ty = EvId -> Type
idType EvId
fun_id
([CoreExpr]
invis_args, [CoreExpr]
rest_args) = Int -> [CoreExpr] -> ([CoreExpr], [CoreExpr])
forall a. Int -> [a] -> ([a], [a])
splitAt (Type -> Int
invisibleBndrCount Type
fun_ty) [CoreExpr]
args
splitHsWrapperArgs :: HsWrapper -> [CoreArg] -> DsM (HsWrapper, [CoreArg])
splitHsWrapperArgs :: HsWrapper -> [CoreExpr] -> DsM (HsWrapper, [CoreExpr])
splitHsWrapperArgs HsWrapper
wrap [CoreExpr]
args = HsWrapper -> [CoreExpr] -> DsM (HsWrapper, [CoreExpr])
go HsWrapper
wrap [CoreExpr]
args
where
go :: HsWrapper -> [CoreExpr] -> DsM (HsWrapper, [CoreExpr])
go (WpTyApp Type
ty) [CoreExpr]
args = (HsWrapper, [CoreExpr]) -> DsM (HsWrapper, [CoreExpr])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
WpHole, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args)
go (WpEvApp EvTerm
tm) [CoreExpr]
args = do { core_tm <- EvTerm -> DsM CoreExpr
dsEvTerm EvTerm
tm
; return (WpHole, core_tm : args)}
go (WpCompose HsWrapper
w1 HsWrapper
w2) [CoreExpr]
args
= do { (w1', args') <- HsWrapper -> [CoreExpr] -> DsM (HsWrapper, [CoreExpr])
go HsWrapper
w1 [CoreExpr]
args
; if isIdHsWrapper w1'
then go w2 args'
else return (w1' <.> w2, args') }
go HsWrapper
wrap [CoreExpr]
args = (HsWrapper, [CoreExpr]) -> DsM (HsWrapper, [CoreExpr])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrap, [CoreExpr]
args)
dsHsConLike :: ConLike -> DsM CoreExpr
dsHsConLike :: ConLike -> DsM CoreExpr
dsHsConLike (RealDataCon DataCon
dc)
= CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvId -> CoreExpr
forall b. EvId -> Expr b
varToCoreExpr (DataCon -> EvId
dataConWrapId DataCon
dc))
dsHsConLike (PatSynCon PatSyn
ps)
| Just (Name
builder_name, Type
_, Bool
add_void) <- PatSyn -> Maybe (Name, Type, Bool)
patSynBuilder PatSyn
ps
= do { builder_id <- Name -> DsM EvId
dsLookupGlobalId Name
builder_name
; return (if add_void
then mkCoreApp (text "dsConLike" <+> ppr ps)
(Var builder_id) unboxedUnitExpr
else Var builder_id) }
| Bool
otherwise
= String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsConLike" (PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
ps)
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 { fun <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
; dsHsWrappers arg_wraps $ \[CoreExpr -> CoreExpr]
core_arg_wraps ->
HsWrapper
-> ((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr
forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
dsHsWrapper HsWrapper
res_wrap (((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr)
-> ((CoreExpr -> CoreExpr) -> DsM CoreExpr) -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ \CoreExpr -> CoreExpr
core_res_wrap ->
do { let wrapped_args :: [CoreExpr]
wrapped_args = String
-> ((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> [CoreExpr -> CoreExpr]
-> [CoreExpr]
-> [CoreExpr]
forall a b c.
HasDebugCallStack =>
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
; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr
core_res_wrap (CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps CoreExpr
fun [CoreExpr]
wrapped_args) } }
dsSyntaxExpr SyntaxExpr GhcTc
SyntaxExprTc
NoSyntaxExprTc [CoreExpr]
_ = String -> DsM CoreExpr
forall a. HasCallStack => String -> a
panic String
"dsSyntaxExpr"
findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
findField :: forall arg. [LHsRecField GhcTc arg] -> Name -> [arg]
findField [LHsRecField GhcTc arg]
rbinds Name
sel
= [HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) arg -> arg
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) arg
fld | L SrcSpanAnnA
_ HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) arg
fld <- [LHsRecField GhcTc arg]
[GenLocated
SrcSpanAnnA
(HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) arg)]
rbinds
, Name
sel Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== EvId -> Name
idName (HsRecField GhcTc arg -> EvId
forall arg. HsRecField GhcTc arg -> EvId
hsRecFieldId HsRecField GhcTc arg
HsFieldBind (GenLocated SrcSpanAnnA (FieldOcc GhcTc)) arg
fld) ]
maxBuildLength :: Int
maxBuildLength :: Int
maxBuildLength = Int
32
dsExplicitList :: Type -> [LHsExpr GhcTc]
-> DsM CoreExpr
dsExplicitList :: Type -> [LHsExpr GhcTc] -> DsM CoreExpr
dsExplicitList Type
elt_ty [LHsExpr GhcTc]
xs
= do { dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; xs' <- mapM dsLExpr xs
; if xs' `lengthExceeds` maxBuildLength
|| null xs'
|| not (gopt Opt_EnableRewriteRules dflags)
then return $ mkListExpr elt_ty xs'
else mkBuildExpr elt_ty (mk_build_list xs') }
where
mk_build_list :: t (Arg b) -> (EvId, b) -> (EvId, b) -> m (Arg b)
mk_build_list t (Arg b)
xs' (EvId
cons, b
_) (EvId
nil, b
_)
= Arg b -> m (Arg b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Arg b -> Arg b -> Arg b) -> Arg b -> t (Arg b) -> Arg b
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
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 (EvId -> Arg b
forall b. EvId -> Expr b
Var EvId
cons)) (EvId -> Arg b
forall b. EvId -> Expr b
Var EvId
nil) t (Arg b)
xs')
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
-> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr)
-> DsM CoreExpr -> DsM CoreExpr
forall a b.
IOEnv (Env DsGblEnv DsLclEnv) (a -> b)
-> IOEnv (Env DsGblEnv DsLclEnv) a
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
from
dsArithSeq HsExpr GhcTc
expr (FromTo LHsExpr GhcTc
from LHsExpr GhcTc
to)
= do fam_envs <- DsM FamInstEnvs
dsGetFamInstEnvs
dflags <- getDynFlags
warnAboutEmptyEnumerations fam_envs dflags from Nothing to
expr' <- dsExpr expr
from' <- dsLExpr from
to' <- dsLExpr to
return $ mkApps expr' [from', 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
<$> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr IOEnv (Env DsGblEnv DsLclEnv) ([CoreExpr] -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr] -> DsM CoreExpr
forall a b.
IOEnv (Env DsGblEnv DsLclEnv) (a -> b)
-> IOEnv (Env DsGblEnv DsLclEnv) a
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LocatedA (HsExpr GhcTc) -> DsM CoreExpr)
-> [LocatedA (HsExpr GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LHsExpr GhcTc -> DsM CoreExpr
LocatedA (HsExpr GhcTc) -> DsM CoreExpr
dsLExpr [LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
from, LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
thn]
dsArithSeq HsExpr GhcTc
expr (FromThenTo LHsExpr GhcTc
from LHsExpr GhcTc
thn LHsExpr GhcTc
to)
= do fam_envs <- DsM FamInstEnvs
dsGetFamInstEnvs
dflags <- getDynFlags
warnAboutEmptyEnumerations fam_envs dflags from (Just thn) to
expr' <- dsExpr expr
from' <- dsLExpr from
thn' <- dsLExpr thn
to' <- dsLExpr to
return $ mkApps expr' [from', thn', to']
dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
dsDo HsDoFlavour
ctx [ExprLStmt GhcTc]
stmts Type
res_ty
= [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
where
goL :: [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [] = String -> DsM CoreExpr
forall a. HasCallStack => String -> a
panic String
"dsDo"
goL ((L SrcSpanAnnA
loc StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
stmt):[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
lstmts) = SrcSpanAnnA -> DsM CoreExpr -> DsM CoreExpr
forall ann a. EpAnn ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc (SrcSpanAnnA
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
go SrcSpanAnnA
loc StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
stmt [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
lstmts)
go :: SrcSpanAnnA
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
go SrcSpanAnnA
_ (LastStmt XLastStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
_ LocatedA (HsExpr GhcTc)
body Maybe Bool
_ SyntaxExpr GhcTc
_) [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
= Bool
-> (LocatedA (HsExpr GhcTc) -> DsM CoreExpr)
-> LocatedA (HsExpr GhcTc)
-> DsM CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert ([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts ) LHsExpr GhcTc -> DsM CoreExpr
LocatedA (HsExpr GhcTc) -> DsM CoreExpr
dsLExpr LocatedA (HsExpr GhcTc)
body
go SrcSpanAnnA
_ (BodyStmt XBodyStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
_ LocatedA (HsExpr GhcTc)
rhs SyntaxExpr GhcTc
then_expr SyntaxExpr GhcTc
_) [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
= do { rhs2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
rhs
; case tcSplitAppTy_maybe (exprType rhs2) of
Just (Type
m_ty, Type
elt_ty) -> LHsExpr GhcTc -> Type -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDiscardedDoBindings LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
rhs Type
m_ty Type
elt_ty
Maybe (Type, Type)
Nothing -> () -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; rest <- goL stmts
; dsSyntaxExpr then_expr [rhs2, rest] }
go SrcSpanAnnA
_ (LetStmt XLetStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
_ HsLocalBinds GhcTc
binds) [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
= do { rest <- [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
; dsLocalBinds binds rest }
go SrcSpanAnnA
_ (BindStmt XBindStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
xbs LPat GhcTc
pat LocatedA (HsExpr GhcTc)
rhs) [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
= do { var <- Type -> LPat GhcTc -> DsM EvId
selectSimpleMatchVarL (XBindStmtTc -> Type
xbstc_boundResultMult XBindStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
XBindStmtTc
xbs) LPat GhcTc
pat
; rhs' <- dsLExpr rhs
; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
(xbstc_boundResultType xbs) (MR_Infallible $ goL stmts)
; match_code <- dsHandleMonadicFailure ctx pat res_ty match (xbstc_failOp xbs)
; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
go SrcSpanAnnA
loc (RecStmt { recS_stmts :: forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts = L SrcSpanAnnLW
_ [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr 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} }) [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
= [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL (GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
new_bind_stmt GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall a. a -> [a] -> [a]
: [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts)
where
new_bind_stmt :: GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
new_bind_stmt = SrcSpanAnnA
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ XBindStmt GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> LPat GhcTc
-> LocatedA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt
XBindStmtTc
{ xbstc_bindOp :: SyntaxExpr GhcTc
xbstc_bindOp = SyntaxExpr GhcTc
bind_op
, xbstc_boundResultType :: Type
xbstc_boundResultType = Type
bind_ty
, xbstc_boundResultMult :: Type
xbstc_boundResultMult = Type
ManyTy
, xbstc_failOp :: Maybe (SyntaxExpr GhcTc)
xbstc_failOp = Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
forall a. Maybe a
Nothing
}
([LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
later_pats)
LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
mfix_app
tup_ids :: [IdP GhcTc]
tup_ids = [IdP GhcTc]
rec_ids [IdP GhcTc] -> [IdP GhcTc] -> [IdP GhcTc]
forall a. [a] -> [a] -> [a]
++ (IdP GhcTc -> Bool) -> [IdP GhcTc] -> [IdP GhcTc]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (IdP GhcTc -> [IdP GhcTc] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IdP GhcTc]
rec_ids) [IdP GhcTc]
later_ids
tup_ty :: Type
tup_ty = [Type] -> Type
HasDebugCallStack => [Type] -> Type
mkBigCoreTupTy ((EvId -> Type) -> [EvId] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map EvId -> Type
idType [IdP GhcTc]
[EvId]
tup_ids)
rec_tup_pats :: [GenLocated SrcSpanAnnA (Pat GhcTc)]
rec_tup_pats = (IdGhcP 'Typechecked -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> [IdGhcP 'Typechecked] -> [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map IdP GhcTc -> LPat GhcTc
IdGhcP 'Typechecked -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [IdP GhcTc]
[IdGhcP 'Typechecked]
tup_ids
later_pats :: [GenLocated SrcSpanAnnA (Pat GhcTc)]
later_pats = [GenLocated SrcSpanAnnA (Pat GhcTc)]
rec_tup_pats
rets :: [LocatedA (HsExpr GhcTc)]
rets = (HsExpr GhcTc -> LocatedA (HsExpr GhcTc))
-> [HsExpr GhcTc] -> [LocatedA (HsExpr GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [HsExpr GhcTc]
rec_rets
mfix_app :: LHsExpr GhcTc
mfix_app = SyntaxExprTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
nlHsSyntaxApps SyntaxExpr GhcTc
SyntaxExprTc
mfix_op [LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
mfix_arg]
match_group :: MatchGroupTc
match_group = [Scaled Type] -> Type -> Origin -> MatchGroupTc
MatchGroupTc [Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
tup_ty] Type
body_ty (GenReason -> DoPmc -> Origin
Generated GenReason
OtherExpansion DoPmc
SkipPmc)
mfix_arg :: LocatedA (HsExpr GhcTc)
mfix_arg = HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsExpr GhcTc -> LocatedA (HsExpr GhcTc))
-> HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XLam GhcTc
-> HsLamVariant -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p.
XLam p -> HsLamVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcTc
forall a. NoAnn a => a
noAnn HsLamVariant
LamSingle
(MG { mg_alts :: XRec GhcTc [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
mg_alts = [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
-> GenLocated SrcSpanAnnLW [LMatch GhcTc (LocatedA (HsExpr GhcTc))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [HsMatchContext (LIdP (NoGhcTc GhcTc))
-> LocatedE [LPat GhcTc]
-> LocatedA (HsExpr GhcTc)
-> LMatch GhcTc (LocatedA (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ EpAnn NoEpAnns) =>
HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> LocatedE [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch
(HsLamVariant -> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsLamVariant -> HsMatchContext fn
LamAlt HsLamVariant
LamSingle)
([GenLocated SrcSpanAnnA (Pat GhcTc)]
-> GenLocated EpaLocation [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [GenLocated SrcSpanAnnA (Pat GhcTc)
mfix_pat]) LocatedA (HsExpr GhcTc)
body]
, mg_ext :: XMG GhcTc (LocatedA (HsExpr GhcTc))
mg_ext = XMG GhcTc (LocatedA (HsExpr GhcTc))
MatchGroupTc
match_group
})
mfix_pat :: GenLocated SrcSpanAnnA (Pat GhcTc)
mfix_pat = Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> Pat GhcTc -> GenLocated SrcSpanAnnA (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 [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
rec_tup_pats
body :: LocatedA (HsExpr GhcTc)
body = HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsExpr GhcTc -> LocatedA (HsExpr GhcTc))
-> HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ XDo GhcTc
-> HsDoFlavour -> XRec GhcTc [ExprLStmt GhcTc] -> HsExpr GhcTc
forall p. XDo p -> HsDoFlavour -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XDo GhcTc
Type
body_ty
HsDoFlavour
ctx ([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> GenLocated
SrcSpanAnnLW
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA ([GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
rec_stmts [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall a. [a] -> [a] -> [a]
++ [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr 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]
[LocatedA (HsExpr GhcTc)]
rets]
ret_stmt :: GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
ret_stmt = StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ LocatedA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
(GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt LHsExpr GhcTc
LocatedA (HsExpr GhcTc)
ret_app
go SrcSpanAnnA
_ (XStmtLR (ApplicativeStmt XApplicativeStmt GhcTc GhcTc
body_ty [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args Maybe (SyntaxExpr GhcTc)
mb_join)) [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts
= do {
let
([(GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)]
pats, [DsM CoreExpr]
rhss) = [((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
DsM CoreExpr)]
-> ([(GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)],
[DsM CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip (((SyntaxExprTc, ApplicativeArg GhcTc)
-> ((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
DsM CoreExpr))
-> [(SyntaxExprTc, ApplicativeArg GhcTc)]
-> [((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
DsM CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (ApplicativeArg GhcTc
-> ((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
DsM CoreExpr)
do_arg (ApplicativeArg GhcTc
-> ((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
DsM CoreExpr))
-> ((SyntaxExprTc, ApplicativeArg GhcTc) -> ApplicativeArg GhcTc)
-> (SyntaxExprTc, ApplicativeArg GhcTc)
-> ((GenLocated SrcSpanAnnA (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
-> ((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
DsM CoreExpr)
do_arg (ApplicativeArgOne XApplicativeArgOne GhcTc
fail_op LPat GhcTc
pat LHsExpr GhcTc
expr Bool
_) =
((LPat GhcTc
GenLocated SrcSpanAnnA (Pat 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 HsDoFlavour
_) =
((LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat, Maybe SyntaxExprTc
forall a. Maybe a
Nothing), HsDoFlavour -> [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
dsDo HsDoFlavour
ctx ([ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
stmts [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
-> [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
forall a. [a] -> [a] -> [a]
++ [StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))))
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ LocatedA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc))
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
(GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt (HsExpr GhcTc -> LocatedA (HsExpr GhcTc)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA HsExpr GhcTc
ret)]) Type
res_ty)
; rhss' <- [DsM CoreExpr] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [DsM CoreExpr]
rhss
; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)
; let match_args (GenLocated SrcSpanAnnA (Pat GhcTc)
pat, Maybe SyntaxExprTc
fail_op) ([EvId]
vs,CoreExpr
body)
= SrcSpan -> DsM ([EvId], CoreExpr) -> DsM ([EvId], CoreExpr)
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (GenLocated SrcSpanAnnA (Pat GhcTc) -> SrcSpan
forall a e. HasLoc a => GenLocated a e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (Pat GhcTc)
pat) (DsM ([EvId], CoreExpr) -> DsM ([EvId], CoreExpr))
-> DsM ([EvId], CoreExpr) -> DsM ([EvId], CoreExpr)
forall a b. (a -> b) -> a -> b
$
do { var <- Type -> LPat GhcTc -> DsM EvId
selectSimpleMatchVarL Type
ManyTy LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat
; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
body_ty (cantFailMatchResult body)
; match_code <- dsHandleMonadicFailure ctx pat body_ty match fail_op
; return (var:vs, match_code)
}
; (vars, body) <- foldrM match_args ([],body') pats
; let fun' = [EvId] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvId]
vars CoreExpr
body
; let mk_ap_call CoreExpr
l (SyntaxExprTc
op,CoreExpr
r) = SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
SyntaxExprTc
op [CoreExpr
l,CoreExpr
r]
; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
; case mb_join of
Maybe (SyntaxExpr GhcTc)
Nothing -> CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr
Just SyntaxExpr GhcTc
join_op -> SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
join_op [CoreExpr
expr] }
go SrcSpanAnnA
_ (ParStmt {}) [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
_ = String -> DsM CoreExpr
forall a. HasCallStack => String -> a
panic String
"dsDo ParStmt"
go SrcSpanAnnA
_ (TransStmt {}) [GenLocated
SrcSpanAnnA (StmtLR GhcTc GhcTc (LocatedA (HsExpr GhcTc)))]
_ = String -> DsM CoreExpr
forall a. HasCallStack => String -> a
panic String
"dsDo TransStmt"
warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> Type -> DsM ()
warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDiscardedDoBindings LHsExpr GhcTc
rhs Type
m_ty Type
elt_ty
= do { warn_unused <- WarningFlag -> TcRnIf DsGblEnv DsLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnUnusedDoBind
; warn_wrong <- woptM Opt_WarnWrongDoBind
; when (warn_unused || warn_wrong) $
do { fam_inst_envs <- dsGetFamInstEnvs
; let norm_elt_ty = FamInstEnvs -> Type -> Type
topNormaliseType FamInstEnvs
fam_inst_envs Type
elt_ty
; if warn_unused && not (isUnitTy norm_elt_ty)
then diagnosticDs (DsUnusedDoBind rhs elt_ty)
else
when warn_wrong $
case tcSplitAppTy_maybe norm_elt_ty of
Just (Type
elt_m_ty, Type
_)
| Type
m_ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` FamInstEnvs -> Type -> Type
topNormaliseType FamInstEnvs
fam_inst_envs Type
elt_m_ty
-> DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs (LHsExpr GhcTc -> Type -> DsMessage
DsWrongDoBind LHsExpr GhcTc
rhs Type
elt_ty)
Maybe (Type, Type)
_ -> () -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return () } }