{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
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 ( addTyCs, pmcGRHSs )
import GHC.HsToCore.Errors.Types
import GHC.Types.SourceText
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Core.FamInstEnv( topNormaliseType )
import GHC.HsToCore.Quote
import GHC.Hs
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
import GHC.Core.Type
import GHC.Core.TyCo.Rep
import GHC.Core.Multiplicity
import GHC.Core.Coercion( instNewTyCon_maybe, mkSymCo )
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.Types.Var.Env
import GHC.Unit.Module
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Types.Basic
import GHC.Data.Maybe
import GHC.Types.SrcLoc
import GHC.Types.Tickish
import GHC.Utils.Misc
import GHC.Data.Bag
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Core.PatSyn
import Control.Monad
dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds (EmptyLocalBinds XEmptyLocalBinds GhcTc GhcTc
_) CoreExpr
body = CoreExpr -> DsM CoreExpr
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 binds _)) CoreExpr
body
= ((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> CoreExpr -> DsM CoreExpr)
-> CoreExpr
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
-> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))
-> CoreExpr -> DsM CoreExpr
ds_val_bind CoreExpr
body [(RecFlag, LHsBinds GhcTc)]
[(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc 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 TcEvBinds
XIPBinds GhcTc
ev_binds
; 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 _ (IPBind n _ 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
return (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (CoreBndr -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec XCIPBind GhcTc
CoreBndr
n CoreExpr
e') CoreExpr
body)
ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
ds_val_bind (RecFlag
NonRecursive, LHsBinds GhcTc
hsbinds) CoreExpr
body
| [L SrcSpanAnnA
loc HsBindLR GhcTc GhcTc
bind] <- Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
hsbinds
, HsBindLR GhcTc GhcTc -> Bool
isUnliftedHsBind HsBindLR GhcTc GhcTc
bind
= SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
if HsBindLR GhcTc GhcTc -> Bool
forall idL idR.
(XXHsBindsLR idL idR ~ AbsBinds) =>
HsBindLR idL idR -> Bool
is_polymorphic HsBindLR GhcTc GhcTc
bind
then DsMessage -> DsM CoreExpr
errDsCoreExpr (HsBindLR GhcTc GhcTc -> DsMessage
DsCannotMixPolyAndUnliftedBindings HsBindLR GhcTc GhcTc
bind)
else do { Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HsBindLR GhcTc GhcTc -> Bool
looksLazyPatBind HsBindLR GhcTc 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 (HsBindLR GhcTc GhcTc -> DsMessage
DsUnbangedStrictPatterns HsBindLR GhcTc GhcTc
bind)
; HsBindLR GhcTc GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind HsBindLR GhcTc GhcTc
bind CoreExpr
body }
where
is_polymorphic :: HsBindLR idL idR -> Bool
is_polymorphic (XHsBindsLR (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
= Bool -> Bool
not ([CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBndr]
tvs Bool -> Bool -> Bool
&& [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBndr]
evs)
is_polymorphic HsBindLR idL idR
_ = Bool
False
ds_val_bind (RecFlag
is_rec, LHsBinds GhcTc
binds) CoreExpr
_body
| (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> Bool)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)) -> Bool
forall a. (a -> Bool) -> Bag a -> Bool
anyBag (HsBindLR GhcTc GhcTc -> Bool
isUnliftedHsBind (HsBindLR GhcTc GhcTc -> Bool)
-> (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> HsBindLR GhcTc GhcTc)
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> HsBindLR GhcTc GhcTc
forall l e. GenLocated l e -> e
unLoc) LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc 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
$ [LHsBindLR GhcTc GhcTc] -> DsMessage
DsRecBindsNotAllowedForUnliftedTys (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a. Bag a -> [a]
bagToList LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds)
ds_val_bind (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
|| Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)) -> Bool
forall a. Bag a -> Bool
isSingletonBag LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds)
; ([CoreBndr]
force_vars,[(CoreBndr, CoreExpr)]
prs) <- LHsBinds GhcTc -> DsM ([CoreBndr], [(CoreBndr, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
; let body' :: CoreExpr
body' = (CoreBndr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreBndr] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreBndr -> CoreExpr -> CoreExpr
seqVar CoreExpr
body [CoreBndr]
force_vars
; Bool -> SDoc -> DsM CoreExpr -> DsM CoreExpr
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Bool -> Bool
not (((CoreBndr, CoreExpr) -> Bool) -> [(CoreBndr, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType (Type -> Bool)
-> ((CoreBndr, CoreExpr) -> Type) -> (CoreBndr, CoreExpr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Type
idType (CoreBndr -> Type)
-> ((CoreBndr, CoreExpr) -> CoreBndr)
-> (CoreBndr, CoreExpr)
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBndr, CoreExpr) -> CoreBndr
forall a b. (a, b) -> a
fst) [(CoreBndr, CoreExpr)]
prs)) (RecFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecFlag
is_rec SDoc -> SDoc -> SDoc
$$ Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds) (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
case [(CoreBndr, CoreExpr)]
prs of
[] -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
body
[(CoreBndr, CoreExpr)]
_ -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let ([(CoreBndr, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr, CoreExpr)]
prs) CoreExpr
body') }
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind :: HsBindLR GhcTc GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (XHsBindsLR (AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_exports = exports
, abs_ev_binds = ev_binds
, abs_binds = lbinds })) CoreExpr
body
= do { let body1 :: CoreExpr
body1 = (ABExport -> CoreExpr -> CoreExpr)
-> CoreExpr -> [ABExport] -> CoreExpr
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 = CoreBndr -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec (ABExport -> CoreBndr
abe_poly ABExport
export) (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var (ABExport -> CoreBndr
abe_mono ABExport
export)) CoreExpr
b
; CoreExpr
body2 <- (CoreExpr
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> DsM CoreExpr)
-> CoreExpr
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc 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 (HsBindLR GhcTc GhcTc)
lbind -> HsBindLR GhcTc GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> HsBindLR GhcTc GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
lbind) CoreExpr
body)
CoreExpr
body1 LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
lbinds
; [CoreBind]
ds_binds <- [TcEvBinds] -> DsM [CoreBind]
dsTcEvBinds_s [TcEvBinds]
ev_binds
; CoreExpr -> DsM CoreExpr
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 l 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 -> [CoreTickish]
fun_tick = [CoreTickish]
tick }) CoreExpr
body
= do { ([CoreBndr]
args, CoreExpr
rhs) <- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([CoreBndr], CoreExpr)
matchWrapper (LIdP GhcRn -> HsMatchContext GhcRn
forall p. LIdP p -> HsMatchContext p
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
$ CoreBndr -> Name
idName CoreBndr
fun))
Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
; Bool -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ([CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBndr]
args)
; Bool -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (HsWrapper -> Bool
isIdHsWrapper HsWrapper
XFunBind GhcTc GhcTc
co_fn)
; let rhs' :: CoreExpr
rhs' = [CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox [CoreTickish]
tick CoreExpr
rhs
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec CoreBndr
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 = XPatBind GhcTc GhcTc
ty }) CoreExpr
body
=
do { NonEmpty Nablas
match_nablas <- HsMatchContext GhcRn
-> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
pmcGRHSs HsMatchContext GhcRn
forall p. HsMatchContext p
PatBindGuards GRHSs GhcTc (LHsExpr GhcTc)
grhss
; CoreExpr
rhs <- GRHSs GhcTc (LHsExpr GhcTc)
-> Type -> NonEmpty Nablas -> DsM CoreExpr
dsGuarded GRHSs GhcTc (LHsExpr GhcTc)
grhss XPatBind GhcTc GhcTc
Type
ty NonEmpty Nablas
match_nablas
; let upat :: Pat GhcTc
upat = GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc LPat GhcTc
GenLocated SrcSpanAnnA (Pat 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 }
; CoreBndr
var <- Type -> Pat GhcTc -> DsM CoreBndr
selectMatchVar Type
Many Pat GhcTc
upat
; CoreExpr
result <- HsMatchContext GhcRn
-> [CoreBndr] -> [EquationInfo] -> Type -> DsM CoreExpr
matchEquations HsMatchContext GhcRn
forall p. HsMatchContext p
PatBindRhs [CoreBndr
var] [EquationInfo
eqn] (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
body)
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec CoreBndr
var CoreExpr
rhs CoreExpr
result) }
dsUnliftedBind HsBindLR GhcTc GhcTc
bind CoreExpr
body = String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsLet: unlifted" (HsBindLR GhcTc GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBindLR GhcTc GhcTc
bind SDoc -> SDoc -> SDoc
$$ CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
body)
dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (L loc e) =
SrcSpanAnnA -> DsM CoreExpr -> DsM CoreExpr
forall ann a. SrcSpanAnn' 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 (HsVar XVar GhcTc
_ (L _ id)) = CoreBndr -> DsM CoreExpr
dsHsVar CoreBndr
id
dsExpr (HsRecSel XRecSel GhcTc
_ (FieldOcc XCFieldOcc GhcTc
id XRec GhcTc RdrName
_)) = CoreBndr -> DsM CoreExpr
dsHsVar XCFieldOcc GhcTc
CoreBndr
id
dsExpr (HsUnboundVar (HER ref _ _) OccName
_) = 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
_ LHsToken "(" GhcTc
_ LHsExpr GhcTc
e LHsToken ")" GhcTc
_) = 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 (HsIPVar XIPVar GhcTc
x HsIPName
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen DataConCantHappen
XIPVar GhcTc
x
dsExpr (HsGetField XGetField GhcTc
x LHsExpr GhcTc
_ XRec GhcTc (DotFieldOcc GhcTc)
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen DataConCantHappen
XGetField GhcTc
x
dsExpr (HsProjection XProjection GhcTc
x NonEmpty (XRec GhcTc (DotFieldOcc GhcTc))
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen DataConCantHappen
XProjection GhcTc
x
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 e :: HsExpr GhcTc
e@(XExpr XXExpr GhcTc
ext_expr_tc)
= case XXExpr GhcTc
ext_expr_tc of
ExpansionExpr (HsExpanded _ b) -> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
b
WrapExpr {} -> HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped HsExpr GhcTc
e
ConLikeTc con tvs tys -> ConLike -> [TcInvisTVBinder] -> [Scaled Type] -> DsM CoreExpr
dsConLike ConLike
con [TcInvisTVBinder]
tvs [Scaled Type]
tys
HsTick tickish e -> do
CoreExpr
e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish CoreExpr
e')
HsBinTick ixT ixF e -> do
CoreExpr
e2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
do { Bool
-> (Int -> Int -> CoreExpr -> DsM CoreExpr)
-> Int
-> Int
-> CoreExpr
-> DsM CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
e2 Type -> Type -> Bool
`eqType` Type
boolTy)
Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox Int
ixT Int
ixF CoreExpr
e2
}
dsExpr (NegApp XNegApp GhcTc
_ (L loc
(HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
SyntaxExpr GhcTc
neg_expr)
= do { CoreExpr
expr' <- SrcSpanAnnA -> DsM CoreExpr -> DsM CoreExpr
forall ann a. SrcSpanAnn' 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 :: 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)
= ([CoreBndr] -> CoreExpr -> CoreExpr)
-> ([CoreBndr], CoreExpr) -> CoreExpr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [CoreBndr] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams (([CoreBndr], CoreExpr) -> CoreExpr)
-> DsM ([CoreBndr], CoreExpr) -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([CoreBndr], 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 { ([CoreBndr
discrim_var], CoreExpr
matching_code) <- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([CoreBndr], 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
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
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
; CoreExpr
arg' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
arg
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs (String -> SDoc
text String
"HsApp" SDoc -> SDoc -> SDoc
<+> HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
e) CoreExpr
fun' CoreExpr
arg' }
dsExpr e :: HsExpr GhcTc
e@(HsAppType {}) = HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped HsExpr GhcTc
e
dsExpr (ExplicitTuple XExplicitTuple GhcTc
_ [HsTupArg GhcTc]
tup_args Boxity
boxity)
= do { let go :: ([CoreBndr], [CoreExpr])
-> HsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr])
go ([CoreBndr]
lam_vars, [CoreExpr]
args) (Missing (Scaled mult ty))
= do { CoreBndr
lam_var <- Type -> Type -> DsM CoreBndr
newSysLocalDs Type
mult Type
ty
; ([CoreBndr], [CoreExpr])
-> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr])
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr
lam_var CoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
: [CoreBndr]
lam_vars, CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
lam_var CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args) }
go ([CoreBndr]
lam_vars, [CoreExpr]
args) (Present XPresent GhcTc
_ LHsExpr GhcTc
expr)
= do { CoreExpr
core_expr <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
; ([CoreBndr], [CoreExpr])
-> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr])
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreBndr]
lam_vars, CoreExpr
core_expr CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args) }
; ([CoreBndr]
lam_vars, [CoreExpr]
args) <- (([CoreBndr], [CoreExpr])
-> HsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr]))
-> ([CoreBndr], [CoreExpr])
-> [HsTupArg GhcTc]
-> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([CoreBndr], [CoreExpr])
-> HsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr])
go ([], []) ([HsTupArg GhcTc] -> [HsTupArg GhcTc]
forall a. [a] -> [a]
reverse [HsTupArg GhcTc]
tup_args)
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ [CoreBndr] -> CoreExpr -> CoreExpr
mkCoreLams [CoreBndr]
lam_vars (Boxity -> [CoreExpr] -> CoreExpr
mkCoreTupBoxity Boxity
boxity [CoreExpr]
args) }
dsExpr (ExplicitSum XExplicitSum GhcTc
types Int
alt Int
arity LHsExpr GhcTc
expr)
= Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUbxSum 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
_ 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
; ([CoreBndr
discrim_var], CoreExpr
matching_code) <- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([CoreBndr], CoreExpr)
matchWrapper HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> Maybe a
Just LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
discrim) MatchGroup GhcTc (LHsExpr GhcTc)
matches
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec CoreBndr
discrim_var CoreExpr
core_discrim CoreExpr
matching_code) }
dsExpr (HsLet XLet GhcTc
_ LHsToken "let" GhcTc
_ HsLocalBinds GhcTc
binds LHsToken "in" GhcTc
_ LHsExpr GhcTc
body) = do
CoreExpr
body' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
body
HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds HsLocalBinds GhcTc
binds CoreExpr
body'
dsExpr (HsDo XDo GhcTc
res_ty HsDoFlavour
ListComp (L _ stmts)) = [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
dsListComp [ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts XDo GhcTc
Type
res_ty
dsExpr (HsDo XDo GhcTc
_ ctx :: HsDoFlavour
ctx@DoExpr{} (L _ stmts)) = HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsDoFlavour
ctx [ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
dsExpr (HsDo XDo GhcTc
_ ctx :: HsDoFlavour
ctx@HsDoFlavour
GhciStmtCtxt (L _ stmts)) = HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsDoFlavour
ctx [ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
dsExpr (HsDo XDo GhcTc
_ ctx :: HsDoFlavour
ctx@MDoExpr{} (L _ stmts)) = HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsDoFlavour
ctx [ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
dsExpr (HsDo XDo GhcTc
_ HsDoFlavour
MonadComp (L _ stmts)) = [ExprLStmt GhcTc] -> DsM CoreExpr
dsMonadComp [ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
dsExpr (HsIf XIf GhcTc
_ 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
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
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)
| [GenLocated
(SrcAnn NoEpAnns)
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LGRHS GhcTc (LHsExpr GhcTc)]
[GenLocated
(SrcAnn NoEpAnns)
(GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts
= DsM CoreExpr
mkErrorExpr
| Bool
otherwise
= do { let grhss :: GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss = XCGRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> HsLocalBinds GhcTc
-> GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall p body.
XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
EpAnnComments
emptyComments [LGRHS GhcTc (LHsExpr GhcTc)]
[LGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
alts HsLocalBinds GhcTc
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds
; NonEmpty Nablas
rhss_nablas <- HsMatchContext GhcRn
-> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
pmcGRHSs HsMatchContext GhcRn
forall p. HsMatchContext p
IfAlt GRHSs GhcTc (LHsExpr GhcTc)
GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss
; MatchResult CoreExpr
match_result <- HsMatchContext GhcRn
-> GRHSs GhcTc (LHsExpr GhcTc)
-> Type
-> NonEmpty Nablas
-> DsM (MatchResult CoreExpr)
dsGRHSs HsMatchContext GhcRn
forall p. HsMatchContext p
IfAlt GRHSs GhcTc (LHsExpr GhcTc)
GRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
grhss XMultiIf GhcTc
Type
res_ty NonEmpty Nablas
rhss_nablas
; CoreExpr
error_expr <- DsM CoreExpr
mkErrorExpr
; MatchResult CoreExpr -> CoreExpr -> DsM CoreExpr
extractMatchResult MatchResult CoreExpr
match_result CoreExpr
error_expr }
where
mkErrorExpr :: DsM CoreExpr
mkErrorExpr = CoreBndr -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs CoreBndr
nON_EXHAUSTIVE_GUARDS_ERROR_ID XMultiIf GhcTc
Type
res_ty
(String -> SDoc
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 HsExpr GhcTc
XArithSeq GhcTc
expr ArithSeqInfo GhcTc
seq
Just SyntaxExpr GhcTc
fl -> do { CoreExpr
newArithSeq <- HsExpr GhcTc -> ArithSeqInfo GhcTc -> DsM CoreExpr
dsArithSeq HsExpr GhcTc
XArithSeq GhcTc
expr ArithSeqInfo GhcTc
seq
; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
fl [CoreExpr
newArithSeq] }
dsExpr (HsStatic (_, whole_ty) expr :: LHsExpr GhcTc
expr@(L loc _)) = do
CoreExpr
expr_ds <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
let (TyCon
_, [Type
ty]) = Type -> (TyCon, [Type])
splitTyConApp Type
whole_ty
CoreBndr
makeStaticId <- Name -> DsM CoreBndr
dsLookupGlobalId Name
makeStaticName
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
let (Int
line, Int
col) = case SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
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
]
SrcSpanAnnA -> DsM CoreExpr -> DsM CoreExpr
forall ann a. SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
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
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
makeStaticId) [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty, CoreExpr
srcLoc, CoreExpr
expr_ds ]
dsExpr (RecordCon { rcon_con :: forall p. HsExpr p -> XRec p (ConLikeP p)
rcon_con = L _ 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 { CoreExpr
con_expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
XRecordCon GhcTc
con_expr
; let
([Scaled Type]
arg_tys, Type
_) = Type -> ([Scaled Type], Type)
tcSplitFunTys (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
con_expr')
mk_arg :: (Type, FieldLabel) -> DsM CoreExpr
mk_arg (Type
arg_ty, FieldLabel
fl)
= case [LHsRecField GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> Name -> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall arg. [LHsRecField GhcTc arg] -> Name -> [arg]
findField (HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [LHsRecField GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds HsRecordBinds GhcTc
HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rbinds) (FieldLabel -> Name
flSelector FieldLabel
fl) of
(GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs:[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
rhss) -> Bool
-> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> DsM CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert ([GenLocated SrcSpanAnnA (HsExpr GhcTc)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
rhss)
LHsExpr GhcTc -> DsM CoreExpr
GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr
dsLExpr GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
[] -> CoreBndr -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs CoreBndr
rEC_CON_ERROR_ID Type
arg_ty (FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl))
unlabelled_bottom :: Type -> DsM CoreExpr
unlabelled_bottom Type
arg_ty = CoreBndr -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs CoreBndr
rEC_CON_ERROR_ID Type
arg_ty SDoc
Outputable.empty
labels :: [FieldLabel]
labels = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con_like
; [CoreExpr]
con_args <- if [FieldLabel] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLabel]
labels
then (Type -> DsM CoreExpr)
-> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM CoreExpr
unlabelled_bottom ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys)
else ((Type, FieldLabel) -> DsM CoreExpr)
-> [(Type, FieldLabel)] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type, FieldLabel) -> DsM CoreExpr
mk_arg (String -> [Type] -> [FieldLabel] -> [(Type, FieldLabel)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"dsExpr:RecordCon" ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys) [FieldLabel]
labels)
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps CoreExpr
con_expr' [CoreExpr]
con_args) }
dsExpr RecordUpd { rupd_flds :: forall p. HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Right [LHsRecUpdProj GhcTc]
_} =
String -> DsM CoreExpr
forall a. String -> a
panic String
"The impossible happened"
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 -> Either [LHsRecUpdField p] [LHsRecUpdProj p]
rupd_flds = Left [LHsRecUpdField GhcTc]
fields
, rupd_ext :: forall p. HsExpr p -> XRecordUpd p
rupd_ext = RecordUpdTc
{ rupd_cons = cons_to_upd
, rupd_in_tys = in_inst_tys
, rupd_out_tys = out_inst_tys
, rupd_wrap = dict_req_wrap }} )
| [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsRecUpdField GhcTc]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
fields
= LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
record_expr
| Bool
otherwise
= Bool -> SDoc -> DsM CoreExpr -> DsM CoreExpr
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([ConLike] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [ConLike]
cons_to_upd) (HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr) (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
do { CoreExpr
record_expr' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
record_expr
; [(Name, CoreBndr, CoreExpr)]
field_binds' <- (GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, CoreBndr, CoreExpr))
-> [GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Name, CoreBndr, CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecUpdField GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, CoreBndr, CoreExpr)
GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, CoreBndr, CoreExpr)
ds_field [LHsRecUpdField GhcTc]
[GenLocated
SrcSpanAnnA
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
fields
; let upd_fld_env :: NameEnv Id
upd_fld_env :: NameEnv CoreBndr
upd_fld_env = [(Name, CoreBndr)] -> NameEnv CoreBndr
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name
f,CoreBndr
l) | (Name
f,CoreBndr
l,CoreExpr
_) <- [(Name, CoreBndr, CoreExpr)]
field_binds']
; [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts <- (ConLike
-> IOEnv
(Env DsGblEnv DsLclEnv)
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))))
-> [ConLike]
-> IOEnv
(Env DsGblEnv DsLclEnv)
[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NameEnv CoreBndr
-> ConLike
-> IOEnv
(Env DsGblEnv DsLclEnv)
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
mk_alt NameEnv CoreBndr
upd_fld_env) [ConLike]
cons_to_upd
; ([CoreBndr
discrim_var], CoreExpr
matching_code)
<- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([CoreBndr], CoreExpr)
matchWrapper HsMatchContext GhcRn
forall p. HsMatchContext p
RecUpd (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> Maybe a
Just LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
record_expr)
(MG :: forall p body.
XMG p body -> XRec p [LMatch p body] -> Origin -> MatchGroup p body
MG { mg_alts :: XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
mg_alts = [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> LocatedAn
AnnList
[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a an. a -> LocatedAn an a
noLocA [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
alts
, mg_ext :: XMG GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mg_ext = [Scaled Type] -> Type -> MatchGroupTc
MatchGroupTc [Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
in_ty] Type
out_ty
, mg_origin :: Origin
mg_origin = Origin
FromSource
})
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
forall a. [(a, CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [(Name, CoreBndr, CoreExpr)]
field_binds' (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreBndr -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec CoreBndr
discrim_var CoreExpr
record_expr' CoreExpr
matching_code) }
where
ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
ds_field :: LHsRecUpdField GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, CoreBndr, CoreExpr)
ds_field (L _ rec_field)
= do { CoreExpr
rhs <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))
rec_field)
; let fld_id :: CoreBndr
fld_id = GenLocated SrcSpan CoreBndr -> CoreBndr
forall l e. GenLocated l e -> e
unLoc (HsFieldBind
(LAmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpan CoreBndr
forall arg.
HsFieldBind (LAmbiguousFieldOcc GhcTc) arg
-> GenLocated SrcSpan CoreBndr
hsRecUpdFieldId HsFieldBind
(LAmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcTc))
(GenLocated SrcSpanAnnA (HsExpr GhcTc))
rec_field)
; CoreBndr
lcl_id <- Type -> Type -> DsM CoreBndr
newSysLocalDs (CoreBndr -> Type
idMult CoreBndr
fld_id) (CoreBndr -> Type
idType CoreBndr
fld_id)
; (Name, CoreBndr, CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, CoreBndr, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> Name
idName CoreBndr
fld_id, CoreBndr
lcl_id, CoreExpr
rhs) }
add_field_binds :: [(a, CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [] CoreExpr
expr = CoreExpr
expr
add_field_binds ((a
_,CoreBndr
b,CoreExpr
r):[(a, CoreBndr, CoreExpr)]
bs) CoreExpr
expr = CoreBndr -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec CoreBndr
b CoreExpr
r ([(a, CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [(a, CoreBndr, CoreExpr)]
bs CoreExpr
expr)
(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 CoreBndr
-> ConLike
-> IOEnv
(Env DsGblEnv DsLclEnv)
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
mk_alt NameEnv CoreBndr
upd_fld_env ConLike
con
= do { let ([CoreBndr]
univ_tvs, [CoreBndr]
ex_tvs, [EqSpec]
eq_spec,
[Type]
prov_theta, [Type]
_req_theta, [Scaled Type]
arg_tys, Type
_) = ConLike
-> ([CoreBndr], [CoreBndr], [EqSpec], [Type], [Type],
[Scaled Type], Type)
conLikeFullSig ConLike
con
arg_tys' :: [Scaled Type]
arg_tys' = (Scaled Type -> Scaled Type) -> [Scaled Type] -> [Scaled Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Scaled Type -> Scaled Type
forall a. Type -> Scaled a -> Scaled a
scaleScaled Type
Many) [Scaled Type]
arg_tys
user_tvs :: [CoreBndr]
user_tvs = [TcInvisTVBinder] -> [CoreBndr]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars ([TcInvisTVBinder] -> [CoreBndr])
-> [TcInvisTVBinder] -> [CoreBndr]
forall a b. (a -> b) -> a -> b
$ ConLike -> [TcInvisTVBinder]
conLikeUserTyVarBinders ConLike
con
in_subst :: TCvSubst
in_subst :: TCvSubst
in_subst = TCvSubst -> [CoreBndr] -> TCvSubst
extendTCvInScopeList ([CoreBndr] -> [Type] -> TCvSubst
HasDebugCallStack => [CoreBndr] -> [Type] -> TCvSubst
zipTvSubst [CoreBndr]
univ_tvs [Type]
in_inst_tys) [CoreBndr]
ex_tvs
out_tv_env :: TvSubstEnv
out_tv_env :: TvSubstEnv
out_tv_env = [CoreBndr] -> [Type] -> TvSubstEnv
HasDebugCallStack => [CoreBndr] -> [Type] -> TvSubstEnv
zipTyEnv [CoreBndr]
univ_tvs [Type]
out_inst_tys
; [CoreBndr]
eqs_vars <- (Type -> DsM CoreBndr)
-> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM CoreBndr
newPredVarDs (HasDebugCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
in_subst ([EqSpec] -> [Type]
eqSpecPreds [EqSpec]
eq_spec))
; [CoreBndr]
theta_vars <- (Type -> DsM CoreBndr)
-> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM CoreBndr
newPredVarDs (HasDebugCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
in_subst [Type]
prov_theta)
; [CoreBndr]
arg_ids <- [Scaled Type] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreBndr]
newSysLocalsDs (TCvSubst -> [Scaled Type] -> [Scaled Type]
substScaledTysUnchecked TCvSubst
in_subst [Scaled Type]
arg_tys')
; let field_labels :: [FieldLabel]
field_labels = ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
con
val_args :: [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
val_args = String
-> (FieldLabel
-> CoreBndr -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [FieldLabel]
-> [CoreBndr]
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"dsExpr:RecordUpd" FieldLabel -> CoreBndr -> LHsExpr GhcTc
FieldLabel -> CoreBndr -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
mk_val_arg
[FieldLabel]
field_labels [CoreBndr]
arg_ids
mk_val_arg :: FieldLabel -> CoreBndr -> LHsExpr GhcTc
mk_val_arg FieldLabel
fl CoreBndr
pat_arg_id
= IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (NameEnv CoreBndr -> Name -> Maybe CoreBndr
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv CoreBndr
upd_fld_env (FieldLabel -> Name
flSelector FieldLabel
fl) Maybe CoreBndr -> CoreBndr -> CoreBndr
forall a. Maybe a -> a -> a
`orElse` CoreBndr
pat_arg_id)
inst_con :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
inst_con = HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (ConLike -> HsExpr GhcTc
mkConLikeTc ConLike
con)
wrap :: HsWrapper
wrap = [CoreBndr] -> HsWrapper
mkWpEvVarApps [CoreBndr]
theta_vars HsWrapper -> HsWrapper -> HsWrapper
<.>
HsWrapper
dict_req_wrap HsWrapper -> HsWrapper -> HsWrapper
<.>
[Type] -> HsWrapper
mkWpTyApps [ TvSubstEnv -> CoreBndr -> Maybe Type
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv TvSubstEnv
out_tv_env CoreBndr
tv
Maybe Type -> Type -> Type
forall a. Maybe a -> a -> a
`orElse` CoreBndr -> Type
mkTyVarTy CoreBndr
tv
| CoreBndr
tv <- [CoreBndr]
user_tvs ]
rhs :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs = (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\GenLocated SrcSpanAnnA (HsExpr GhcTc)
a GenLocated SrcSpanAnnA (HsExpr GhcTc)
b -> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
a LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
b) GenLocated SrcSpanAnnA (HsExpr GhcTc)
inst_con [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
val_args
wrapped_rhs :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
wrapped_rhs =
case ConLike
con of
RealDataCon DataCon
data_con
| [EqSpec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EqSpec]
eq_spec -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
| Bool
otherwise -> HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap (TcCoercionN -> HsWrapper
mkWpCastN TcCoercionN
wrap_co) LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
where
rep_tc :: TyCon
rep_tc = DataCon -> TyCon
dataConTyCon DataCon
data_con
wrap_co :: TcCoercionN
wrap_co = TyCon -> [TcCoercionN] -> TcCoercionN
mkTcFamilyTyConAppCo TyCon
rep_tc [TcCoercionN]
univ_cos
univ_cos :: [TcCoercionN]
univ_cos = String
-> (CoreBndr -> Type -> TcCoercionN)
-> [CoreBndr]
-> [Type]
-> [TcCoercionN]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"dsExpr:upd" CoreBndr -> Type -> TcCoercionN
mk_univ_co [CoreBndr]
univ_tvs [Type]
out_inst_tys
mk_univ_co :: TyVar
-> Type
-> Coercion
mk_univ_co :: CoreBndr -> Type -> TcCoercionN
mk_univ_co CoreBndr
univ_tv Type
inst_ty
= case VarEnv TcCoercionN -> CoreBndr -> Maybe TcCoercionN
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv VarEnv TcCoercionN
eq_spec_env CoreBndr
univ_tv of
Just TcCoercionN
co -> TcCoercionN
co
Maybe TcCoercionN
Nothing -> Type -> TcCoercionN
mkTcNomReflCo Type
inst_ty
eq_spec_env :: VarEnv Coercion
eq_spec_env :: VarEnv TcCoercionN
eq_spec_env = [(CoreBndr, TcCoercionN)] -> VarEnv TcCoercionN
forall a. [(CoreBndr, a)] -> VarEnv a
mkVarEnv [ (EqSpec -> CoreBndr
eqSpecTyVar EqSpec
spec, TcCoercionN -> TcCoercionN
mkTcSymCo (CoreBndr -> TcCoercionN
mkTcCoVarCo CoreBndr
eqs_var))
| (EqSpec
spec,CoreBndr
eqs_var) <- String -> [EqSpec] -> [CoreBndr] -> [(EqSpec, CoreBndr)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"dsExpr:upd2" [EqSpec]
eq_spec [CoreBndr]
eqs_vars ]
PatSynCon PatSyn
_ -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
req_wrap :: HsWrapper
req_wrap = HsWrapper
dict_req_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> [Type] -> HsWrapper
mkWpTyApps [Type]
in_inst_tys
pat :: GenLocated SrcSpanAnnA (Pat GhcTc)
pat = Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a an. a -> LocatedAn an a
noLocA (Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat { pat_con :: XRec GhcTc (ConLikeP GhcTc)
pat_con = ConLike -> LocatedAn NameAnn ConLike
forall a an. a -> LocatedAn an a
noLocA ConLike
con
, pat_args :: HsConPatDetails GhcTc
pat_args = [HsPatSigType GhcRn]
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> HsConDetails
(HsPatSigType GhcRn)
(GenLocated SrcSpanAnnA (Pat GhcTc))
(HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)))
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [] ([GenLocated SrcSpanAnnA (Pat GhcTc)]
-> HsConDetails
(HsPatSigType GhcRn)
(GenLocated SrcSpanAnnA (Pat GhcTc))
(HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc))))
-> [GenLocated SrcSpanAnnA (Pat GhcTc)]
-> HsConDetails
(HsPatSigType GhcRn)
(GenLocated SrcSpanAnnA (Pat GhcTc))
(HsRecFields GhcTc (GenLocated SrcSpanAnnA (Pat GhcTc)))
forall a b. (a -> b) -> a -> b
$ (CoreBndr -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> [CoreBndr] -> [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [CoreBndr]
arg_ids
, pat_con_ext :: XConPat GhcTc
pat_con_ext = ConPatTc :: [Type]
-> [CoreBndr] -> [CoreBndr] -> TcEvBinds -> HsWrapper -> ConPatTc
ConPatTc
{ cpt_tvs :: [CoreBndr]
cpt_tvs = [CoreBndr]
ex_tvs
, cpt_dicts :: [CoreBndr]
cpt_dicts = [CoreBndr]
eqs_vars [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ [CoreBndr]
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
}
}
; GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsMatchContext GhcTc
-> [LPat GhcTc]
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch HsMatchContext GhcTc
forall p. HsMatchContext p
RecUpd [LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat] GenLocated SrcSpanAnnA (HsExpr GhcTc)
wrapped_rhs) }
dsExpr (HsTypedBracket (HsBracketTc q _ hs_wrapper ps) LHsExpr GhcTc
_) = Maybe QuoteWrapper
-> HsQuote GhcRn -> [PendingTcSplice] -> DsM CoreExpr
dsBracket Maybe QuoteWrapper
hs_wrapper HsQuote GhcRn
q [PendingTcSplice]
ps
dsExpr (HsUntypedBracket (HsBracketTc q _ hs_wrapper ps) HsQuote GhcTc
_) = Maybe QuoteWrapper
-> HsQuote GhcRn -> [PendingTcSplice] -> DsM CoreExpr
dsBracket Maybe QuoteWrapper
hs_wrapper HsQuote GhcRn
q [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
ppr HsSplice GhcTc
s)
dsExpr (HsProc XProc GhcTc
_ LPat GhcTc
pat LHsCmdTop GhcTc
cmd) = LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr
dsProcExpr LPat GhcTc
pat LHsCmdTop GhcTc
cmd
dsExpr (HsOverLabel XOverLabel GhcTc
x FieldLabelString
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen DataConCantHappen
XOverLabel GhcTc
x
dsExpr (OpApp XOpApp GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen DataConCantHappen
XOpApp GhcTc
x
dsExpr (SectionL XSectionL GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen DataConCantHappen
XSectionL GhcTc
x
dsExpr (SectionR XSectionR GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_) = DataConCantHappen -> DsM CoreExpr
forall a. DataConCantHappen -> a
dataConCantHappen DataConCantHappen
XSectionR GhcTc
x
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
getDynFlags
if DynFlags -> Bool
sccProfilingEnabled DynFlags
dflags
then do
Module
mod_name <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
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
<$> FieldLabelString -> IOEnv (Env DsGblEnv DsLclEnv) CostCentreIndex
getCCIndexDsM FieldLabelString
nm
CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick (CostCentre -> Bool -> Bool -> CoreTickish
forall (pass :: TickishPass).
CostCentre -> Bool -> Bool -> GenTickish pass
ProfNote (FieldLabelString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC FieldLabelString
nm Module
mod_name (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr 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
<$> LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
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 = expr
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap })
[CoreExpr]
arg_exprs
= do { CoreExpr
fun <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
; [CoreExpr -> CoreExpr]
core_arg_wraps <- (HsWrapper -> IOEnv (Env DsGblEnv DsLclEnv) (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)
mapM HsWrapper -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr)
dsHsWrapper [HsWrapper]
arg_wraps
; CoreExpr -> CoreExpr
core_res_wrap <- HsWrapper -> IOEnv (Env DsGblEnv DsLclEnv) (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
; CoreExpr -> DsM CoreExpr
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
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
= [HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)) arg
-> arg
forall lhs rhs. HsFieldBind lhs rhs -> rhs
hfbRHS HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)) arg
fld | L SrcSpanAnnA
_ HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)) arg
fld <- [LHsRecField GhcTc arg]
[GenLocated
SrcSpanAnnA
(HsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcTc)) arg)]
rbinds
, Name
sel Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr -> Name
idName (HsRecField GhcTc arg -> CoreBndr
forall arg. HsRecField GhcTc arg -> CoreBndr
hsRecFieldId HsRecField GhcTc arg
HsFieldBind (GenLocated (SrcAnn NoEpAnns) (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 { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; [CoreExpr]
xs' <- (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr)
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsExpr GhcTc -> DsM CoreExpr
GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr
dsLExpr [LHsExpr GhcTc]
[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
xs
; if [CoreExpr]
xs' [CoreExpr] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
maxBuildLength
Bool -> Bool -> Bool
|| [CoreExpr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreExpr]
xs'
Bool -> Bool -> Bool
|| Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EnableRewriteRules DynFlags
dflags)
then CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
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
-> ((CoreBndr, Type) -> (CoreBndr, Type) -> DsM CoreExpr)
-> DsM CoreExpr
forall (m :: * -> *).
(MonadFail m, MonadThings m, MonadUnique m) =>
Type
-> ((CoreBndr, Type) -> (CoreBndr, Type) -> m CoreExpr)
-> m CoreExpr
mkBuildExpr Type
elt_ty ([CoreExpr] -> (CoreBndr, Type) -> (CoreBndr, Type) -> DsM CoreExpr
forall (m :: * -> *) (t :: * -> *) b b b.
(Monad m, Foldable t) =>
t (Arg b) -> (CoreBndr, b) -> (CoreBndr, b) -> m (Arg b)
mk_build_list [CoreExpr]
xs') }
where
mk_build_list :: t (Arg b) -> (CoreBndr, b) -> (CoreBndr, b) -> m (Arg b)
mk_build_list t (Arg b)
xs' (CoreBndr
cons, b
_) (CoreBndr
nil, b
_)
= Arg b -> m (Arg b)
forall (m :: * -> *) a. Monad m => a -> m a
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
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 (CoreBndr -> Arg b
forall b. CoreBndr -> Expr b
Var CoreBndr
cons)) (CoreBndr -> Arg b
forall b. CoreBndr -> Expr b
Var CoreBndr
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 (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 FamInstEnvs
fam_envs <- DsM FamInstEnvs
dsGetFamInstEnvs
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
FamInstEnvs
-> DynFlags
-> LHsExpr GhcTc
-> Maybe (LHsExpr GhcTc)
-> LHsExpr GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutEmptyEnumerations FamInstEnvs
fam_envs 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
dsLExpr LHsExpr GhcTc
from
CoreExpr
to' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
to
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
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
<$> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr IOEnv (Env DsGblEnv DsLclEnv) ([CoreExpr] -> CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr] -> DsM CoreExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr)
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsExpr GhcTc -> DsM CoreExpr
GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr
dsLExpr [LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
from, LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
thn]
dsArithSeq HsExpr GhcTc
expr (FromThenTo LHsExpr GhcTc
from LHsExpr GhcTc
thn LHsExpr GhcTc
to)
= do FamInstEnvs
fam_envs <- DsM FamInstEnvs
dsGetFamInstEnvs
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
FamInstEnvs
-> DynFlags
-> LHsExpr GhcTc
-> Maybe (LHsExpr GhcTc)
-> LHsExpr GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutEmptyEnumerations FamInstEnvs
fam_envs DynFlags
dflags LHsExpr GhcTc
from (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> Maybe a
Just LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
thn) LHsExpr GhcTc
to
CoreExpr
expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
CoreExpr
from' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
from
CoreExpr
thn' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
thn
CoreExpr
to' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
to
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
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']
dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsDoFlavour
ctx [ExprLStmt GhcTc]
stmts
= [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
where
goL :: [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [] = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsDo"
goL ((L SrcSpanAnnA
loc StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
stmt):[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
lstmts) = SrcSpanAnnA -> DsM CoreExpr -> DsM CoreExpr
forall ann a. SrcSpanAnn' ann -> DsM a -> DsM a
putSrcSpanDsA SrcSpanAnnA
loc (SrcSpanAnnA
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
go SrcSpanAnnA
loc StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
stmt [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
lstmts)
go :: SrcSpanAnnA
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
go SrcSpanAnnA
_ (LastStmt XLastStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
_ GenLocated SrcSpanAnnA (HsExpr GhcTc)
body Maybe Bool
_ SyntaxExpr GhcTc
_) [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
= Bool
-> (GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> DsM CoreExpr
forall a. HasCallStack => Bool -> a -> a
assert ([GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts ) LHsExpr GhcTc -> DsM CoreExpr
GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr
dsLExpr GenLocated SrcSpanAnnA (HsExpr GhcTc)
body
go SrcSpanAnnA
_ (BodyStmt XBodyStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
_ GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs SyntaxExpr GhcTc
then_expr SyntaxExpr GhcTc
_) [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
= do { CoreExpr
rhs2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
; LHsExpr GhcTc -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDiscardedDoBindings LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
rhs2)
; CoreExpr
rest <- [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
then_expr [CoreExpr
rhs2, CoreExpr
rest] }
go SrcSpanAnnA
_ (LetStmt XLetStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
_ HsLocalBinds GhcTc
binds) [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
= do { CoreExpr
rest <- [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
; HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds HsLocalBinds GhcTc
binds CoreExpr
rest }
go SrcSpanAnnA
_ (BindStmt XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
xbs LPat GhcTc
pat GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs) [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
= do { CoreExpr
body <- [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
; CoreExpr
rhs' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs
; CoreBndr
var <- Type -> LPat GhcTc -> DsM CoreBndr
selectSimpleMatchVarL (XBindStmtTc -> Type
xbstc_boundResultMult XBindStmtTc
XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
xbs) LPat GhcTc
pat
; MatchResult CoreExpr
match <- CoreBndr
-> Maybe CoreExpr
-> HsMatchContext GhcRn
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar CoreBndr
var Maybe CoreExpr
forall a. Maybe a
Nothing (HsStmtContext GhcRn -> HsMatchContext GhcRn
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt (HsDoFlavour -> HsStmtContext GhcRn
forall p. HsDoFlavour -> HsStmtContext p
HsDoStmt HsDoFlavour
ctx)) LPat GhcTc
pat
(XBindStmtTc -> Type
xbstc_boundResultType XBindStmtTc
XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
xbs) (CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
body)
; CoreExpr
match_code <- HsDoFlavour
-> LPat GhcTc
-> MatchResult CoreExpr
-> Maybe (SyntaxExpr GhcTc)
-> DsM CoreExpr
dsHandleMonadicFailure HsDoFlavour
ctx LPat GhcTc
pat MatchResult CoreExpr
match (XBindStmtTc -> Maybe (SyntaxExpr GhcTc)
xbstc_failOp XBindStmtTc
XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
xbs)
; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (XBindStmtTc -> SyntaxExpr GhcTc
xbstc_bindOp XBindStmtTc
XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
xbs) [CoreExpr
rhs', CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
var CoreExpr
match_code] }
go SrcSpanAnnA
_ (ApplicativeStmt XApplicativeStmt
GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
body_ty [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args Maybe (SyntaxExpr GhcTc)
mb_join) [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (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) [(SyntaxExprTc, ApplicativeArg GhcTc)]
[(SyntaxExpr GhcTc, 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] -> DsM CoreExpr
dsDo HsDoFlavour
ctx ([ExprLStmt GhcTc]
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a. [a] -> [a] -> [a]
++ [StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a an. a -> LocatedAn an a
noLocA (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (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 -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA HsExpr GhcTc
ret)]))
; [CoreExpr]
rhss' <- [DsM CoreExpr] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
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 -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (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
XApplicativeStmt
GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
body_ty HsDoFlavour
ctx ([GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> LocatedAn
AnnList
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a an. a -> LocatedAn an a
noLocA [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)
; let match_args :: (GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)
-> ([CoreBndr], CoreExpr) -> DsM ([CoreBndr], CoreExpr)
match_args (GenLocated SrcSpanAnnA (Pat GhcTc)
pat, Maybe SyntaxExprTc
fail_op) ([CoreBndr]
vs,CoreExpr
body)
= do { CoreBndr
var <- Type -> LPat GhcTc -> DsM CoreBndr
selectSimpleMatchVarL Type
Many LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat
; MatchResult CoreExpr
match <- CoreBndr
-> Maybe CoreExpr
-> HsMatchContext GhcRn
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar CoreBndr
var Maybe CoreExpr
forall a. Maybe a
Nothing (HsStmtContext GhcRn -> HsMatchContext GhcRn
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt (HsDoFlavour -> HsStmtContext GhcRn
forall p. HsDoFlavour -> HsStmtContext p
HsDoStmt HsDoFlavour
ctx)) LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat
XApplicativeStmt
GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
Type
body_ty (CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
body)
; CoreExpr
match_code <- HsDoFlavour
-> LPat GhcTc
-> MatchResult CoreExpr
-> Maybe (SyntaxExpr GhcTc)
-> DsM CoreExpr
dsHandleMonadicFailure HsDoFlavour
ctx LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
pat MatchResult CoreExpr
match Maybe SyntaxExprTc
Maybe (SyntaxExpr GhcTc)
fail_op
; ([CoreBndr], CoreExpr) -> DsM ([CoreBndr], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr
varCoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
vs, CoreExpr
match_code)
}
; ([CoreBndr]
vars, CoreExpr
body) <- ((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)
-> ([CoreBndr], CoreExpr) -> DsM ([CoreBndr], CoreExpr))
-> ([CoreBndr], CoreExpr)
-> [(GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)]
-> DsM ([CoreBndr], CoreExpr)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)
-> ([CoreBndr], CoreExpr) -> DsM ([CoreBndr], CoreExpr)
match_args ([],CoreExpr
body') [(GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)]
pats
; let fun' :: CoreExpr
fun' = [CoreBndr] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
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 SyntaxExprTc
SyntaxExpr GhcTc
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
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 [(SyntaxExprTc, ApplicativeArg GhcTc)]
[(SyntaxExpr GhcTc, 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
return CoreExpr
expr
Just SyntaxExpr GhcTc
join_op -> SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
join_op [CoreExpr
expr] }
go SrcSpanAnnA
loc (RecStmt { recS_stmts :: forall idL idR body.
StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]
recS_stmts = L _ 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 = bind_ty
, recS_rec_rets = rec_rets
, recS_ret_ty = body_ty} }) [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts
= [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL (GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
new_bind_stmt GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a. a -> [a] -> [a]
: [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)
where
new_bind_stmt :: GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
new_bind_stmt = SrcSpanAnnA
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> LPat GhcTc
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall idL idR body.
XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body
BindStmt
XBindStmtTc :: SyntaxExpr GhcTc
-> Type -> 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_boundResultMult :: Type
xbstc_boundResultMult = Type
Many
, xbstc_failOp :: Maybe (SyntaxExpr GhcTc)
xbstc_failOp = Maybe (SyntaxExpr GhcTc)
forall a. Maybe a
Nothing
}
([LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId [LPat GhcTc]
[GenLocated SrcSpanAnnA (Pat GhcTc)]
later_pats)
LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
mfix_app
tup_ids :: [CoreBndr]
tup_ids = [IdP GhcTc]
[CoreBndr]
rec_ids [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ (CoreBndr -> Bool) -> [CoreBndr] -> [CoreBndr]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (CoreBndr -> [CoreBndr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IdP GhcTc]
[CoreBndr]
rec_ids) [IdP GhcTc]
[CoreBndr]
later_ids
tup_ty :: Type
tup_ty = [Type] -> Type
mkBigCoreTupTy ((CoreBndr -> Type) -> [CoreBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> Type
idType [CoreBndr]
tup_ids)
rec_tup_pats :: [GenLocated SrcSpanAnnA (Pat GhcTc)]
rec_tup_pats = (CoreBndr -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> [CoreBndr] -> [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [CoreBndr]
tup_ids
later_pats :: [GenLocated SrcSpanAnnA (Pat GhcTc)]
later_pats = [GenLocated SrcSpanAnnA (Pat GhcTc)]
rec_tup_pats
rets :: [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
rets = (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [HsExpr GhcTc] -> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA [HsExpr GhcTc]
rec_rets
mfix_app :: LHsExpr GhcTc
mfix_app = SyntaxExprTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
nlHsSyntaxApps SyntaxExprTc
SyntaxExpr GhcTc
mfix_op [LHsExpr GhcTc
GenLocated SrcSpanAnnA (HsExpr GhcTc)
mfix_arg]
mfix_arg :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
mfix_arg = HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr 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 NoExtField
XLam GhcTc
noExtField
(MG :: forall p body.
XMG p body -> XRec p [LMatch p body] -> Origin -> MatchGroup p body
MG { mg_alts :: XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
mg_alts = [GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> LocatedAn
AnnList
[GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a an. a -> LocatedAn an a
noLocA [HsMatchContext GhcTc
-> [LPat GhcTc]
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch
HsMatchContext GhcTc
forall p. HsMatchContext p
LambdaExpr
[LPat GhcTc
GenLocated SrcSpanAnnA (Pat GhcTc)
mfix_pat] GenLocated SrcSpanAnnA (HsExpr GhcTc)
body]
, mg_ext :: XMG GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
mg_ext = [Scaled Type] -> Type -> MatchGroupTc
MatchGroupTc [Type -> Scaled Type
forall a. a -> Scaled a
unrestricted Type
tup_ty] Type
body_ty
, mg_origin :: Origin
mg_origin = Origin
Generated })
mfix_pat :: GenLocated SrcSpanAnnA (Pat GhcTc)
mfix_pat = Pat GhcTc -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall a an. a -> LocatedAn an 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 NoExtField
XLazyPat GhcTc
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 :: GenLocated SrcSpanAnnA (HsExpr GhcTc)
body = HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall a an. a -> LocatedAn an a
noLocA (HsExpr GhcTc -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> HsExpr GhcTc -> GenLocated SrcSpanAnnA (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 (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> LocatedAn
AnnList
[GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a an. a -> LocatedAn an a
noLocA ([GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
rec_stmts [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
forall a. [a] -> [a] -> [a]
++ [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
ret_stmt]))
ret_app :: LHsExpr GhcTc
ret_app = SyntaxExprTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
nlHsSyntaxApps SyntaxExprTc
SyntaxExpr GhcTc
return_op [[LHsExpr GhcTc] -> LHsExpr GhcTc
mkBigLHsTupId [LHsExpr GhcTc]
[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
rets]
ret_stmt :: GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
ret_stmt = StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a an. a -> LocatedAn an a
noLocA (StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (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
GenLocated SrcSpanAnnA (HsExpr GhcTc)
ret_app
go SrcSpanAnnA
_ (ParStmt {}) [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
_ = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsDo ParStmt"
go SrcSpanAnnA
_ (TransStmt {}) [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
_ = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsDo TransStmt"
dsHsVar :: Id -> DsM CoreExpr
dsHsVar :: CoreBndr -> DsM CoreExpr
dsHsVar CoreBndr
var
= CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
varToCoreExpr CoreBndr
var)
dsHsConLike :: ConLike -> DsM CoreExpr
dsHsConLike :: ConLike -> DsM CoreExpr
dsHsConLike (RealDataCon DataCon
dc)
= CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
varToCoreExpr (DataCon -> CoreBndr
dataConWrapId DataCon
dc))
dsHsConLike (PatSynCon PatSyn
ps)
| Just (Name
builder_name, Type
_, Bool
add_void) <- PatSyn -> Maybe (Name, Type, Bool)
patSynBuilder PatSyn
ps
= do { CoreBndr
builder_id <- Name -> DsM CoreBndr
dsLookupGlobalId Name
builder_name
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
add_void
then SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp (String -> SDoc
text String
"dsConLike" SDoc -> SDoc -> SDoc
<+> PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
ps)
(CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
builder_id) (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
voidPrimId)
else CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
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)
dsConLike :: ConLike -> [TcInvisTVBinder] -> [Scaled Type] -> DsM CoreExpr
dsConLike :: ConLike -> [TcInvisTVBinder] -> [Scaled Type] -> DsM CoreExpr
dsConLike ConLike
con [TcInvisTVBinder]
tvbs [Scaled Type]
tys
= do { CoreExpr
ds_con <- ConLike -> DsM CoreExpr
dsHsConLike ConLike
con
; [CoreBndr]
ids <- [Scaled Type] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreBndr]
newSysLocalsDs [Scaled Type]
tys
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreBndr] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
tvs (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[CoreBndr] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
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` [CoreBndr] -> [Type]
mkTyVarTys [CoreBndr]
tvs
CoreExpr -> [CoreBndr] -> CoreExpr
forall b. Expr b -> [CoreBndr] -> Expr b
`mkVarApps` [CoreBndr] -> [CoreBndr]
drop_stupid [CoreBndr]
ids) }
where
tvs :: [CoreBndr]
tvs = [TcInvisTVBinder] -> [CoreBndr]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TcInvisTVBinder]
tvbs
drop_stupid :: [CoreBndr] -> [CoreBndr]
drop_stupid = [Type] -> [CoreBndr] -> [CoreBndr]
forall b a. [b] -> [a] -> [a]
dropList (ConLike -> [Type]
conLikeStupidTheta ConLike
con)
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 ()
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
; if Bool
warn_unused Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isUnitTy Type
norm_elt_ty)
then DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs (LHsExpr GhcTc -> Type -> DsMessage
DsUnusedDoBind LHsExpr GhcTc
rhs Type
elt_ty)
else
Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
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
$
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
-> 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 (m :: * -> *) a. Monad m => a -> m a
return () } }
| Bool
otherwise
= () -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped HsExpr GhcTc
orig_hs_expr
= HsWrapper -> HsExpr GhcTc -> DsM CoreExpr
go HsWrapper
idHsWrapper HsExpr GhcTc
orig_hs_expr
where
go :: HsWrapper -> HsExpr GhcTc -> DsM CoreExpr
go HsWrapper
wrap (HsPar XPar GhcTc
_ LHsToken "(" GhcTc
_ (L _ hs_e) LHsToken ")" GhcTc
_)
= HsWrapper -> HsExpr GhcTc -> DsM CoreExpr
go HsWrapper
wrap HsExpr GhcTc
hs_e
go HsWrapper
wrap1 (XExpr (WrapExpr (HsWrap wrap2 hs_e)))
= HsWrapper -> HsExpr GhcTc -> DsM CoreExpr
go (HsWrapper
wrap1 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap2) HsExpr GhcTc
hs_e
go HsWrapper
wrap (HsAppType XAppTypeE GhcTc
ty (L _ hs_e) LHsWcType (NoGhcTc GhcTc)
_)
= HsWrapper -> HsExpr GhcTc -> DsM CoreExpr
go (HsWrapper
wrap HsWrapper -> HsWrapper -> HsWrapper
<.> Type -> HsWrapper
WpTyApp XAppTypeE GhcTc
Type
ty) HsExpr GhcTc
hs_e
go HsWrapper
wrap (HsVar XVar GhcTc
_ (L _ var))
| CoreBndr
var CoreBndr -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
withDictKey
= do { CoreExpr -> CoreExpr
wrap' <- HsWrapper -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
wrap
; Type -> DsM CoreExpr
ds_withDict (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType (CoreExpr -> CoreExpr
wrap' (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
varToCoreExpr CoreBndr
var))) }
| Bool
otherwise
= do { CoreExpr -> CoreExpr
wrap' <- HsWrapper -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
wrap
; let expr :: CoreExpr
expr = CoreExpr -> CoreExpr
wrap' (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
varToCoreExpr CoreBndr
var)
ty :: Type
ty = HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
expr
; DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; DynFlags -> CoreBndr -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutIdentities DynFlags
dflags CoreBndr
var Type
ty
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr }
go HsWrapper
wrap HsExpr GhcTc
hs_e
= do { CoreExpr -> CoreExpr
wrap' <- HsWrapper -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
wrap
; Origin -> Bag CoreBndr -> DsM CoreExpr -> DsM CoreExpr
forall a. Origin -> Bag CoreBndr -> DsM a -> DsM a
addTyCs Origin
FromSource (HsWrapper -> Bag CoreBndr
hsWrapDictBinders HsWrapper
wrap) (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
hs_e
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr
wrap' CoreExpr
e) } }
ds_withDict :: Type -> DsM CoreExpr
ds_withDict :: Type -> DsM CoreExpr
ds_withDict Type
wrapped_ty
| Just (Anon AnonArgFlag
VisArg (Scaled Type
mult1 Type
st), Type
rest) <- Type -> Maybe (TyCoBinder, Type)
splitPiTy_maybe Type
wrapped_ty
, Just (Anon AnonArgFlag
VisArg (Scaled Type
mult2 Type
dt_to_r), Type
_r1) <- Type -> Maybe (TyCoBinder, Type)
splitPiTy_maybe Type
rest
, Just (Anon AnonArgFlag
InvisArg (Scaled Type
_ Type
dt), Type
_r2) <- Type -> Maybe (TyCoBinder, Type)
splitPiTy_maybe Type
dt_to_r
, Just (TyCon
dict_tc, [Type]
dict_args) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
dt
, Just (Type
inst_meth_ty, TcCoercionN
co) <- TyCon -> [Type] -> Maybe (Type, TcCoercionN)
instNewTyCon_maybe TyCon
dict_tc [Type]
dict_args
, Type
st Type -> Type -> Bool
`eqType` Type
inst_meth_ty
= do { CoreBndr
sv <- Type -> Type -> DsM CoreBndr
newSysLocalDs Type
mult1 Type
st
; CoreBndr
k <- Type -> Type -> DsM CoreBndr
newSysLocalDs Type
mult2 Type
dt_to_r
; CoreExpr -> DsM CoreExpr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ [CoreBndr] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr
sv, CoreBndr
k] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
k CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr -> TcCoercionN -> CoreExpr
forall b. Expr b -> TcCoercionN -> Expr b
Cast (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
sv) (TcCoercionN -> TcCoercionN
mkSymCo TcCoercionN
co) }
| Bool
otherwise
= DsMessage -> DsM CoreExpr
errDsCoreExpr (Type -> DsMessage
DsInvalidInstantiationDictAtType Type
wrapped_ty)