{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.HsToCore.Expr
( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
, dsValBinds, dsLit, dsSyntaxExpr
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.HsToCore.Match
import GHC.HsToCore.Match.Literal
import GHC.HsToCore.Binds
import GHC.HsToCore.GuardedRHSs
import GHC.HsToCore.ListComp
import GHC.HsToCore.Utils
import GHC.HsToCore.Arrows
import GHC.HsToCore.Monad
import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )
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.Multiplicity
import GHC.Core.Coercion( Coercion )
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.Core.TyCo.Ppr( pprWithTYPE )
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.Core.PatSyn
import Control.Monad
import Data.Void( absurd )
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).
Data (HsLocalBinds (GhcPass p)) =>
HsLocalBinds (GhcPass p) -> SrcSpan
spanHsLocaLBinds HsLocalBinds GhcTc
b) (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
HsValBindsLR GhcTc GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds HsValBindsLR GhcTc GhcTc
binds CoreExpr
body
dsLocalBinds (HsIPBinds XHsIPBinds GhcTc GhcTc
_ HsIPBinds GhcTc
binds) CoreExpr
body = HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds HsIPBinds GhcTc
binds CoreExpr
body
dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds :: HsValBindsLR GhcTc GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds (XValBindsLR (NValBinds [(RecFlag, LHsBinds GhcTc)]
binds [LSig GhcRn]
_)) CoreExpr
body
= ((RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)))
-> CoreExpr -> DsM CoreExpr)
-> CoreExpr
-> [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)))]
-> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)))
-> CoreExpr -> DsM CoreExpr
(RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
ds_val_bind CoreExpr
body [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)))]
[(RecFlag, LHsBinds GhcTc)]
binds
dsValBinds (ValBinds {}) CoreExpr
_ = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsValBinds ValBindsIn"
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds (IPBinds XIPBinds GhcTc
ev_binds [LIPBind GhcTc]
ip_binds) CoreExpr
body
= do { [CoreBind]
ds_binds <- TcEvBinds -> DsM [CoreBind]
dsTcEvBinds XIPBinds GhcTc
TcEvBinds
ev_binds
; let inner :: CoreExpr
inner = [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_binds CoreExpr
body
; (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 GenLocated SrcSpanAnnA (IPBind GhcTc) -> CoreExpr -> DsM CoreExpr
LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
ds_ip_bind CoreExpr
inner [GenLocated SrcSpanAnnA (IPBind GhcTc)]
[LIPBind GhcTc]
ip_binds }
where
ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
ds_ip_bind (L SrcSpanAnnA
_ (IPBind XCIPBind GhcTc
_ ~(Right IdP GhcTc
n) LHsExpr GhcTc
e)) CoreExpr
body
= do CoreExpr
e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
IdP GhcTc
n CoreExpr
e') CoreExpr
body)
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 HsBind GhcTc
bind] <- Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
-> [GenLocated SrcSpanAnnA (HsBind GhcTc)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
LHsBinds GhcTc
hsbinds
, HsBind GhcTc -> Bool
isUnliftedHsBind HsBind GhcTc
bind
= SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
if HsBind GhcTc -> Bool
forall {idL} {idR}. HsBindLR idL idR -> Bool
is_polymorphic HsBind GhcTc
bind
then SDoc -> DsM CoreExpr
errDsCoreExpr (HsBind GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
poly_bind_err HsBind GhcTc
bind)
else do { Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HsBind GhcTc -> Bool
forall (p :: Pass). HsBind (GhcPass p) -> Bool
looksLazyPatBind HsBind GhcTc
bind) (IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
WarningFlag -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnIfSetDs WarningFlag
Opt_WarnUnbangedStrictPatterns (HsBind GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
unlifted_must_be_bang HsBind GhcTc
bind)
; HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind HsBind GhcTc
bind CoreExpr
body }
where
is_polymorphic :: HsBindLR idL idR -> Bool
is_polymorphic (AbsBinds { abs_tvs :: forall idL idR. HsBindLR idL idR -> [Id]
abs_tvs = [Id]
tvs, abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [Id]
abs_ev_vars = [Id]
evs })
= Bool -> Bool
not ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
tvs Bool -> Bool -> Bool
&& [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
evs)
is_polymorphic HsBindLR idL idR
_ = Bool
False
unlifted_must_be_bang :: a -> SDoc
unlifted_must_be_bang a
bind
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Pattern bindings containing unlifted types should use" SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"an outermost bang pattern:")
Int
2 (a -> SDoc
forall {a}. Outputable a => a -> SDoc
ppr a
bind)
poly_bind_err :: a -> SDoc
poly_bind_err a
bind
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"You can't mix polymorphic and unlifted bindings:")
Int
2 (a -> SDoc
forall {a}. Outputable a => a -> SDoc
ppr a
bind) SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"Probable fix: add a type signature"
ds_val_bind (RecFlag
is_rec, LHsBinds GhcTc
binds) CoreExpr
_body
| (GenLocated SrcSpanAnnA (HsBind GhcTc) -> Bool)
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)) -> Bool
forall a. (a -> Bool) -> Bag a -> Bool
anyBag (HsBind GhcTc -> Bool
isUnliftedHsBind (HsBind GhcTc -> Bool)
-> (GenLocated SrcSpanAnnA (HsBind GhcTc) -> HsBind GhcTc)
-> GenLocated SrcSpanAnnA (HsBind GhcTc)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBind GhcTc) -> HsBind GhcTc
forall l e. GenLocated l e -> e
unLoc) Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
LHsBinds GhcTc
binds
= ASSERT( isRec is_rec )
SDoc -> DsM CoreExpr
errDsCoreExpr (SDoc -> DsM CoreExpr) -> SDoc -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Recursive bindings for unlifted types aren't allowed:")
Int
2 ([SDoc] -> SDoc
vcat ((GenLocated SrcSpanAnnA (HsBind GhcTc) -> SDoc)
-> [GenLocated SrcSpanAnnA (HsBind GhcTc)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsBind GhcTc) -> SDoc
forall {a}. Outputable a => a -> SDoc
ppr (Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
-> [GenLocated SrcSpanAnnA (HsBind GhcTc)]
forall a. Bag a -> [a]
bagToList Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
LHsBinds GhcTc
binds)))
ds_val_bind (RecFlag
is_rec, LHsBinds GhcTc
binds) CoreExpr
body
= do { MASSERT( isRec is_rec || isSingletonBag binds )
; ([Id]
force_vars,[(Id, CoreExpr)]
prs) <- LHsBinds GhcTc -> DsM ([Id], [(Id, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
; let body' :: CoreExpr
body' = (Id -> CoreExpr -> CoreExpr) -> CoreExpr -> [Id] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Id -> CoreExpr -> CoreExpr
seqVar CoreExpr
body [Id]
force_vars
; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
case [(Id, CoreExpr)]
prs of
[] -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
body
[(Id, 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 ([(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CoreExpr)]
prs) CoreExpr
body') }
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (AbsBinds { abs_tvs :: forall idL idR. HsBindLR idL idR -> [Id]
abs_tvs = [], abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [Id]
abs_ev_vars = []
, abs_exports :: forall idL idR. HsBindLR idL idR -> [ABExport idL]
abs_exports = [ABExport GhcTc]
exports
, abs_ev_binds :: forall idL idR. HsBindLR idL idR -> [TcEvBinds]
abs_ev_binds = [TcEvBinds]
ev_binds
, abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds = LHsBinds GhcTc
lbinds }) CoreExpr
body
= do { let body1 :: CoreExpr
body1 = (ABExport GhcTc -> CoreExpr -> CoreExpr)
-> CoreExpr -> [ABExport GhcTc] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ABExport GhcTc -> CoreExpr -> CoreExpr
forall {p}. (IdP p ~ Id) => ABExport p -> CoreExpr -> CoreExpr
bind_export CoreExpr
body [ABExport GhcTc]
exports
bind_export :: ABExport p -> CoreExpr -> CoreExpr
bind_export ABExport p
export CoreExpr
b = Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec (ABExport p -> IdP p
forall p. ABExport p -> IdP p
abe_poly ABExport p
export) (Id -> CoreExpr
forall b. Id -> Expr b
Var (ABExport p -> IdP p
forall p. ABExport p -> IdP p
abe_mono ABExport p
export)) CoreExpr
b
; CoreExpr
body2 <- (CoreExpr -> GenLocated SrcSpanAnnA (HsBind GhcTc) -> DsM CoreExpr)
-> CoreExpr
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
-> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\CoreExpr
body GenLocated SrcSpanAnnA (HsBind GhcTc)
lbind -> HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (GenLocated SrcSpanAnnA (HsBind GhcTc) -> HsBind GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsBind GhcTc)
lbind) CoreExpr
body)
CoreExpr
body1 Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
LHsBinds GhcTc
lbinds
; [CoreBind]
ds_binds <- [TcEvBinds] -> DsM [CoreBind]
dsTcEvBinds_s [TcEvBinds]
ev_binds
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_binds CoreExpr
body2) }
dsUnliftedBind (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
l Id
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 { ([Id]
args, CoreExpr
rhs) <- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper (LIdP GhcRn -> HsMatchContext GhcRn
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (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
$ Id -> Name
idName Id
fun))
Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
; MASSERT( null args )
; MASSERT( isIdHsWrapper 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 (Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
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 Type
XPatBind GhcTc GhcTc
ty NonEmpty Nablas
match_nablas
; let upat :: Pat GhcTc
upat = GenLocated SrcSpanAnnA (Pat GhcTc) -> Pat GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat
eqn :: EquationInfo
eqn = EqnInfo { eqn_pats :: [Pat GhcTc]
eqn_pats = [Pat GhcTc
upat],
eqn_orig :: Origin
eqn_orig = Origin
FromSource,
eqn_rhs :: MatchResult CoreExpr
eqn_rhs = CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
body }
; Id
var <- Type -> Pat GhcTc -> DsM Id
selectMatchVar Type
Many Pat GhcTc
upat
; CoreExpr
result <- HsMatchContext GhcRn
-> [Id] -> [EquationInfo] -> Type -> DsM CoreExpr
matchEquations HsMatchContext GhcRn
forall p. HsMatchContext p
PatBindRhs [Id
var] [EquationInfo
eqn] (CoreExpr -> Type
exprType CoreExpr
body)
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
var CoreExpr
rhs CoreExpr
result) }
dsUnliftedBind HsBind GhcTc
bind CoreExpr
body = String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsLet: unlifted" (HsBind GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
ppr HsBind 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 SrcSpanAnnA
loc HsExpr GhcTc
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
dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP (L SrcSpanAnnA
loc HsExpr GhcTc
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
$
do { CoreExpr
e' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
e
; CoreExpr -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
dsNoLevPolyExpr CoreExpr
e' (String -> SDoc
text String
"In the type of expression:" SDoc -> SDoc -> SDoc
<+> HsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
ppr HsExpr GhcTc
e)
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e' }
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsExpr (HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Id
id)) = Id -> DsM CoreExpr
dsHsVar Id
id
dsExpr (HsRecFld XRecFld GhcTc
_ (Unambiguous XUnambiguous GhcTc
id LocatedN RdrName
_)) = Id -> DsM CoreExpr
dsHsVar Id
XUnambiguous GhcTc
id
dsExpr (HsRecFld XRecFld GhcTc
_ (Ambiguous XAmbiguous GhcTc
id LocatedN RdrName
_)) = Id -> DsM CoreExpr
dsHsVar Id
XAmbiguous GhcTc
id
dsExpr (HsUnboundVar (HER IORef EvTerm
ref Type
_ Unique
_) 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
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
dsExpr (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
_) = LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
dsExpr (HsConLikeOut XConLikeOut GhcTc
_ ConLike
con) = ConLike -> DsM CoreExpr
dsConLike ConLike
con
dsExpr (HsIPVar {}) = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr: HsIPVar"
dsExpr (HsGetField XGetField GhcTc
x LHsExpr GhcTc
_ Located (HsFieldLabel GhcTc)
_) = Void -> DsM CoreExpr
forall a. Void -> a
absurd Void
XGetField GhcTc
x
dsExpr (HsProjection XProjection GhcTc
x NonEmpty (Located (HsFieldLabel GhcTc))
_) = Void -> DsM CoreExpr
forall a. Void -> a
absurd Void
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
expansion)
= case XXExpr GhcTc
expansion of
ExpansionExpr (HsExpanded HsExpr GhcRn
_ HsExpr GhcTc
b) -> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
b
WrapExpr {} -> HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped HsExpr GhcTc
e
dsExpr (NegApp XNegApp GhcTc
_ (L SrcSpanAnnA
loc
(HsOverLit XOverLitE GhcTc
_ lit :: HsOverLit GhcTc
lit@(OverLit { ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = HsIntegral IntegralLit
i})))
SyntaxExpr GhcTc
neg_expr)
= do { CoreExpr
expr' <- 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)
= ([Id] -> CoreExpr -> CoreExpr) -> ([Id], CoreExpr) -> CoreExpr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams (([Id], CoreExpr) -> CoreExpr)
-> DsM ([Id], CoreExpr) -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper HsMatchContext GhcRn
forall p. HsMatchContext p
LambdaExpr Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
a_Match
dsExpr (HsLamCase XLamCase GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
matches)
= do { ([Id
discrim_var], CoreExpr
matching_code) <- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
discrim_var CoreExpr
matching_code }
dsExpr e :: HsExpr GhcTc
e@(HsApp XApp GhcTc
_ LHsExpr GhcTc
fun LHsExpr GhcTc
arg)
= do { CoreExpr
fun' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
fun
; DsM CoreExpr -> (CoreExpr -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs (LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
arg)
(\CoreExpr
arg' -> SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs (String -> SDoc
text String
"HsApp" SDoc -> SDoc -> SDoc
<+> HsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
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 :: ([Id], [CoreExpr])
-> HsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
go ([Id]
lam_vars, [CoreExpr]
args) (Missing (Scaled Type
mult Type
ty))
= do { Id
lam_var <- Type -> Type -> DsM Id
newSysLocalDsNoLP Type
mult Type
ty
; ([Id], [CoreExpr])
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
lam_var Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
lam_vars, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
lam_var CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args) }
go ([Id]
lam_vars, [CoreExpr]
args) (Present XPresent GhcTc
_ LHsExpr GhcTc
expr)
= do { CoreExpr
core_expr <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
expr
; ([Id], [CoreExpr])
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
lam_vars, CoreExpr
core_expr CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args) }
; IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
-> (([Id], [CoreExpr]) -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs ((([Id], [CoreExpr])
-> HsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr]))
-> ([Id], [CoreExpr])
-> [HsTupArg GhcTc]
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([Id], [CoreExpr])
-> HsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([Id], [CoreExpr])
go ([], []) ([HsTupArg GhcTc] -> [HsTupArg GhcTc]
forall a. [a] -> [a]
reverse [HsTupArg GhcTc]
tup_args))
(\([Id]
lam_vars, [CoreExpr]
args) ->
[Id] -> CoreExpr -> CoreExpr
mkCoreLams [Id]
lam_vars (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
Boxity -> [CoreExpr] -> CoreExpr
mkCoreTupBoxity Boxity
boxity [CoreExpr]
args) }
dsExpr (ExplicitSum XExplicitSum GhcTc
types Int
alt Int
arity LHsExpr GhcTc
expr)
= DsM CoreExpr -> (CoreExpr -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs (LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
expr) (Int -> Int -> [Type] -> CoreExpr -> CoreExpr
mkCoreUbxSum Int
arity Int
alt [Type]
XExplicitSum GhcTc
types)
dsExpr (HsPragE XPragE GhcTc
_ HsPragE GhcTc
prag LHsExpr GhcTc
expr) =
HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
ds_prag_expr HsPragE GhcTc
prag LHsExpr GhcTc
expr
dsExpr (HsCase XCase GhcTc
_ LHsExpr GhcTc
discrim MatchGroup GhcTc (LHsExpr GhcTc)
matches)
= do { CoreExpr
core_discrim <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
discrim
; ([Id
discrim_var], CoreExpr
matching_code) <- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> Maybe a
Just GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
discrim) MatchGroup GhcTc (LHsExpr GhcTc)
matches
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
discrim_var CoreExpr
core_discrim CoreExpr
matching_code) }
dsExpr (HsLet XLet GhcTc
_ HsLocalBinds GhcTc
binds 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 HsStmtContext (HsDoRn GhcTc)
ListComp (L SrcSpanAnnL
_ [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)) = [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
dsListComp [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[ExprLStmt GhcTc]
stmts Type
XDo GhcTc
res_ty
dsExpr (HsDo XDo GhcTc
_ ctx :: HsStmtContext (HsDoRn GhcTc)
ctx@DoExpr{} (L SrcSpanAnnL
_ [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)) = HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsStmtContext GhcRn
HsStmtContext (HsDoRn GhcTc)
ctx [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[ExprLStmt GhcTc]
stmts
dsExpr (HsDo XDo GhcTc
_ ctx :: HsStmtContext (HsDoRn GhcTc)
ctx@HsStmtContext (HsDoRn GhcTc)
GhciStmtCtxt (L SrcSpanAnnL
_ [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)) = HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsStmtContext GhcRn
HsStmtContext (HsDoRn GhcTc)
ctx [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[ExprLStmt GhcTc]
stmts
dsExpr (HsDo XDo GhcTc
_ ctx :: HsStmtContext (HsDoRn GhcTc)
ctx@MDoExpr{} (L SrcSpanAnnL
_ [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)) = HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsStmtContext GhcRn
HsStmtContext (HsDoRn GhcTc)
ctx [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[ExprLStmt GhcTc]
stmts
dsExpr (HsDo XDo GhcTc
_ HsStmtContext (HsDoRn GhcTc)
MonadComp (L SrcSpanAnnL
_ [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
stmts)) = [ExprLStmt GhcTc] -> DsM CoreExpr
dsMonadComp [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[ExprLStmt 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
SrcSpan (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
SrcSpan (GRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[LGRHS GhcTc (LHsExpr 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 EpAnnComments
XCGRHSs GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
emptyComments [LGRHS GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
[LGRHS GhcTc (LHsExpr 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 (GenLocated SrcSpanAnnA (HsExpr GhcTc))
GRHSs GhcTc (LHsExpr 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 (GenLocated SrcSpanAnnA (HsExpr GhcTc))
GRHSs GhcTc (LHsExpr GhcTc)
grhss Type
XMultiIf GhcTc
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 = Id -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
nON_EXHAUSTIVE_GUARDS_ERROR_ID Type
XMultiIf GhcTc
res_ty
(String -> SDoc
text String
"multi-way if")
dsExpr (ExplicitList XExplicitList GhcTc
elt_ty [LHsExpr GhcTc]
xs) = Type -> [LHsExpr GhcTc] -> DsM CoreExpr
dsExplicitList Type
XExplicitList GhcTc
elt_ty [LHsExpr GhcTc]
xs
dsExpr (ArithSeq XArithSeq GhcTc
expr Maybe (SyntaxExpr GhcTc)
witness ArithSeqInfo GhcTc
seq)
= case Maybe (SyntaxExpr GhcTc)
witness of
Maybe (SyntaxExpr GhcTc)
Nothing -> HsExpr GhcTc -> ArithSeqInfo GhcTc -> DsM CoreExpr
dsArithSeq XArithSeq GhcTc
HsExpr GhcTc
expr ArithSeqInfo GhcTc
seq
Just SyntaxExpr GhcTc
fl -> do { CoreExpr
newArithSeq <- HsExpr GhcTc -> ArithSeqInfo GhcTc -> DsM CoreExpr
dsArithSeq XArithSeq GhcTc
HsExpr GhcTc
expr ArithSeqInfo GhcTc
seq
; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
fl [CoreExpr
newArithSeq] }
dsExpr (HsStatic XStatic GhcTc
_ expr :: LHsExpr GhcTc
expr@(L SrcSpanAnnA
loc HsExpr GhcTc
_)) = do
CoreExpr
expr_ds <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
expr
let ty :: Type
ty = CoreExpr -> Type
exprType CoreExpr
expr_ds
Id
makeStaticId <- Name -> DsM Id
dsLookupGlobalId Name
makeStaticName
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
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 (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
makeStaticId) [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty, CoreExpr
srcLoc, CoreExpr
expr_ds ]
dsExpr (RecordCon { rcon_con :: forall p. HsExpr p -> XRec p (ConLikeP p)
rcon_con = L SrcSpanAnnN
_ ConLike
con_like
, rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcTc
rbinds
, rcon_ext :: forall p. HsExpr p -> XRecordCon p
rcon_ext = XRecordCon GhcTc
con_expr })
= do { CoreExpr
con_expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr XRecordCon GhcTc
HsExpr GhcTc
con_expr
; let
([Scaled Type]
arg_tys, Type
_) = Type -> ([Scaled Type], Type)
tcSplitFunTys (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 HsRecFields GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
HsRecordBinds GhcTc
rbinds) (FieldLabel -> Name
flSelector FieldLabel
fl) of
(GenLocated SrcSpanAnnA (HsExpr GhcTc)
rhs:[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
rhss) -> ASSERT( null rhss )
LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
rhs
[] -> Id -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
rEC_CON_ERROR_ID Type
arg_ty (FieldLabelString -> SDoc
forall {a}. Outputable a => a -> SDoc
ppr (FieldLabel -> FieldLabelString
flLabel FieldLabel
fl))
unlabelled_bottom :: Type -> DsM CoreExpr
unlabelled_bottom Type
arg_ty = Id -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs Id
rEC_CON_ERROR_ID Type
arg_ty SDoc
Outputable.empty
labels :: [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 :: RecordUpdTc -> [ConLike]
rupd_cons = [ConLike]
cons_to_upd
, rupd_in_tys :: RecordUpdTc -> [Type]
rupd_in_tys = [Type]
in_inst_tys
, rupd_out_tys :: RecordUpdTc -> [Type]
rupd_out_tys = [Type]
out_inst_tys
, rupd_wrap :: RecordUpdTc -> HsWrapper
rupd_wrap = HsWrapper
dict_req_wrap }} )
| [GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[LHsRecUpdField GhcTc]
fields
= LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
record_expr
| Bool
otherwise
= ASSERT2( notNull cons_to_upd, ppr expr )
do { CoreExpr
record_expr' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
record_expr
; [(Name, Id, CoreExpr)]
field_binds' <- (GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, Id, CoreExpr))
-> [GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Name, Id, CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, Id, CoreExpr)
LHsRecUpdField GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, Id, CoreExpr)
ds_field [GenLocated
SrcSpanAnnA
(HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[LHsRecUpdField GhcTc]
fields
; let upd_fld_env :: NameEnv Id
upd_fld_env :: NameEnv Id
upd_fld_env = [(Name, Id)] -> NameEnv Id
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name
f,Id
l) | (Name
f,Id
l,CoreExpr
_) <- [(Name, Id, CoreExpr)]
field_binds']
; [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 Id
-> ConLike
-> IOEnv
(Env DsGblEnv DsLclEnv)
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
mk_alt NameEnv Id
upd_fld_env) [ConLike]
cons_to_upd
; ([Id
discrim_var], CoreExpr
matching_code)
<- HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper HsMatchContext GhcRn
forall p. HsMatchContext p
RecUpd (GenLocated SrcSpanAnnA (HsExpr GhcTc)
-> Maybe (GenLocated SrcSpanAnnA (HsExpr GhcTc))
forall a. a -> Maybe a
Just GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
record_expr)
(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, Id, CoreExpr)] -> CoreExpr -> CoreExpr
forall {a}. [(a, Id, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [(Name, Id, CoreExpr)]
field_binds' (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
discrim_var CoreExpr
record_expr' CoreExpr
matching_code) }
where
ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
ds_field :: LHsRecUpdField GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, Id, CoreExpr)
ds_field (L SrcSpanAnnA
_ HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rec_field)
= do { CoreExpr
rhs <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpanAnnA (HsExpr GhcTc)
forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rec_field)
; let fld_id :: Id
fld_id = GenLocated SrcSpan Id -> Id
forall l e. GenLocated l e -> e
unLoc (HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> GenLocated SrcSpan Id
forall arg.
HsRecField' (AmbiguousFieldOcc GhcTc) arg -> GenLocated SrcSpan Id
hsRecUpdFieldId HsRecField'
(AmbiguousFieldOcc GhcTc) (GenLocated SrcSpanAnnA (HsExpr GhcTc))
rec_field)
; Id
lcl_id <- Type -> Type -> DsM Id
newSysLocalDs (Id -> Type
idMult Id
fld_id) (Id -> Type
idType Id
fld_id)
; (Name, Id, CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, Id, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> Name
idName Id
fld_id, Id
lcl_id, CoreExpr
rhs) }
add_field_binds :: [(a, Id, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [] CoreExpr
expr = CoreExpr
expr
add_field_binds ((a
_,Id
b,CoreExpr
r):[(a, Id, CoreExpr)]
bs) CoreExpr
expr = Id -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec Id
b CoreExpr
r ([(a, Id, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [(a, Id, CoreExpr)]
bs CoreExpr
expr)
(Type
in_ty, Type
out_ty) =
case ([ConLike] -> ConLike
forall a. [a] -> a
head [ConLike]
cons_to_upd) of
RealDataCon DataCon
data_con ->
let tycon :: TyCon
tycon = DataCon -> TyCon
dataConTyCon DataCon
data_con in
(TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type]
in_inst_tys, TyCon -> [Type] -> Type
mkFamilyTyConApp TyCon
tycon [Type]
out_inst_tys)
PatSynCon PatSyn
pat_syn ->
( PatSyn -> [Type] -> Type
patSynInstResTy PatSyn
pat_syn [Type]
in_inst_tys
, PatSyn -> [Type] -> Type
patSynInstResTy PatSyn
pat_syn [Type]
out_inst_tys)
mk_alt :: NameEnv Id
-> ConLike
-> IOEnv
(Env DsGblEnv DsLclEnv)
(GenLocated
SrcSpanAnnA (Match GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))))
mk_alt NameEnv Id
upd_fld_env ConLike
con
= do { let ([Id]
univ_tvs, [Id]
ex_tvs, [EqSpec]
eq_spec,
[Type]
prov_theta, [Type]
_req_theta, [Scaled Type]
arg_tys, Type
_) = ConLike
-> ([Id], [Id], [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 :: [Id]
user_tvs = [VarBndr Id Specificity] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars ([VarBndr Id Specificity] -> [Id])
-> [VarBndr Id Specificity] -> [Id]
forall a b. (a -> b) -> a -> b
$ ConLike -> [VarBndr Id Specificity]
conLikeUserTyVarBinders ConLike
con
in_subst :: TCvSubst
in_subst :: TCvSubst
in_subst = TCvSubst -> [Id] -> TCvSubst
extendTCvInScopeList ([Id] -> [Type] -> TCvSubst
HasDebugCallStack => [Id] -> [Type] -> TCvSubst
zipTvSubst [Id]
univ_tvs [Type]
in_inst_tys) [Id]
ex_tvs
out_tv_env :: TvSubstEnv
out_tv_env :: TvSubstEnv
out_tv_env = [Id] -> [Type] -> TvSubstEnv
HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
zipTyEnv [Id]
univ_tvs [Type]
out_inst_tys
; [Id]
eqs_vars <- (Type -> DsM Id) -> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM Id
newPredVarDs (HasCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
in_subst ([EqSpec] -> [Type]
eqSpecPreds [EqSpec]
eq_spec))
; [Id]
theta_vars <- (Type -> DsM Id) -> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM Id
newPredVarDs (HasCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
in_subst [Type]
prov_theta)
; [Id]
arg_ids <- [Scaled Type] -> IOEnv (Env DsGblEnv DsLclEnv) [Id]
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 -> Id -> GenLocated SrcSpanAnnA (HsExpr GhcTc))
-> [FieldLabel]
-> [Id]
-> [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"dsExpr:RecordUpd" FieldLabel -> Id -> GenLocated SrcSpanAnnA (HsExpr GhcTc)
FieldLabel -> Id -> LHsExpr GhcTc
mk_val_arg
[FieldLabel]
field_labels [Id]
arg_ids
mk_val_arg :: FieldLabel -> Id -> LHsExpr GhcTc
mk_val_arg FieldLabel
fl Id
pat_arg_id
= IdP GhcTc -> LHsExpr GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (NameEnv Id -> Name -> Maybe Id
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv Id
upd_fld_env (FieldLabel -> Name
flSelector FieldLabel
fl) Maybe Id -> Id -> Id
forall a. Maybe a -> a -> a
`orElse` Id
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 (XConLikeOut GhcTc -> ConLike -> HsExpr GhcTc
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut NoExtField
XConLikeOut GhcTc
noExtField ConLike
con)
wrap :: HsWrapper
wrap = [Id] -> HsWrapper
mkWpEvVarApps [Id]
theta_vars HsWrapper -> HsWrapper -> HsWrapper
<.>
HsWrapper
dict_req_wrap HsWrapper -> HsWrapper -> HsWrapper
<.>
[Type] -> HsWrapper
mkWpTyApps [ TvSubstEnv -> Id -> Maybe Type
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv TvSubstEnv
out_tv_env Id
tv
Maybe Type -> Type -> Type
forall a. Maybe a -> a -> a
`orElse` Id -> Type
mkTyVarTy Id
tv
| Id
tv <- [Id]
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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
a GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr 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) GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr 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
-> (Id -> Type -> TcCoercionN) -> [Id] -> [Type] -> [TcCoercionN]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"dsExpr:upd" Id -> Type -> TcCoercionN
mk_univ_co [Id]
univ_tvs [Type]
out_inst_tys
mk_univ_co :: TyVar
-> Type
-> Coercion
mk_univ_co :: Id -> Type -> TcCoercionN
mk_univ_co Id
univ_tv Type
inst_ty
= case VarEnv TcCoercionN -> Id -> Maybe TcCoercionN
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv TcCoercionN
eq_spec_env Id
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 = [(Id, TcCoercionN)] -> VarEnv TcCoercionN
forall a. [(Id, a)] -> VarEnv a
mkVarEnv [ (EqSpec -> Id
eqSpecTyVar EqSpec
spec, TcCoercionN -> TcCoercionN
mkTcSymCo (Id -> TcCoercionN
mkTcCoVarCo Id
eqs_var))
| (EqSpec
spec,Id
eqs_var) <- String -> [EqSpec] -> [Id] -> [(EqSpec, Id)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"dsExpr:upd2" [EqSpec]
eq_spec [Id]
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 { pat_con :: XRec GhcTc (ConLikeP GhcTc)
pat_con = ConLike -> GenLocated SrcSpanAnnN ConLike
forall a an. a -> LocatedAn an a
noLocA ConLike
con
, pat_args :: HsConPatDetails GhcTc
pat_args = [HsPatSigType (NoGhcTc GhcTc)]
-> [LPat GhcTc] -> HsConPatDetails GhcTc
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
PrefixCon [] ([LPat GhcTc] -> HsConPatDetails GhcTc)
-> [LPat GhcTc] -> HsConPatDetails GhcTc
forall a b. (a -> b) -> a -> b
$ (Id -> LPat GhcTc) -> [Id] -> [LPat GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> LPat GhcTc
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [Id]
arg_ids
, pat_con_ext :: XConPat GhcTc
pat_con_ext = ConPatTc
{ cpt_tvs :: [Id]
cpt_tvs = [Id]
ex_tvs
, cpt_dicts :: [Id]
cpt_dicts = [Id]
eqs_vars [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
theta_vars
, cpt_binds :: TcEvBinds
cpt_binds = TcEvBinds
emptyTcEvBinds
, cpt_arg_tys :: [Type]
cpt_arg_tys = [Type]
in_inst_tys
, cpt_wrap :: HsWrapper
cpt_wrap = HsWrapper
req_wrap
}
}
; 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 (NoGhcTc 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)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch HsMatchContext (NoGhcTc GhcTc)
forall p. HsMatchContext p
RecUpd [GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat] GenLocated SrcSpanAnnA (HsExpr GhcTc)
wrapped_rhs) }
dsExpr (HsRnBracketOut XRnBracketOut GhcTc
_ HsBracket (HsBracketRn GhcTc)
_ [PendingRnSplice' GhcTc]
_) = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr HsRnBracketOut"
dsExpr (HsTcBracketOut XTcBracketOut GhcTc
_ Maybe QuoteWrapper
hs_wrapper HsBracket (HsBracketRn GhcTc)
x [PendingTcSplice' GhcTc]
ps) = Maybe QuoteWrapper
-> HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr
dsBracket Maybe QuoteWrapper
hs_wrapper HsBracket GhcRn
HsBracket (HsBracketRn GhcTc)
x [PendingTcSplice' GhcTc]
[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 (HsTick XTick GhcTc
_ CoreTickish
tickish LHsExpr GhcTc
e) = do
CoreExpr
e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreTickish -> CoreExpr -> CoreExpr
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tickish CoreExpr
e')
dsExpr (HsBinTick XBinTick GhcTc
_ Int
ixT Int
ixF LHsExpr GhcTc
e) = do
CoreExpr
e2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
do { ASSERT(exprType e2 `eqType` boolTy)
Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox Int
ixT Int
ixF CoreExpr
e2
}
dsExpr (HsOverLabel XOverLabel GhcTc
x FieldLabelString
_) = Void -> DsM CoreExpr
forall a. Void -> a
absurd Void
XOverLabel GhcTc
x
dsExpr (OpApp XOpApp GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_ LHsExpr GhcTc
_) = Void -> DsM CoreExpr
forall a. Void -> a
absurd Void
XOpApp GhcTc
x
dsExpr (SectionL XSectionL GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_) = Void -> DsM CoreExpr
forall a. Void -> a
absurd Void
XSectionL GhcTc
x
dsExpr (SectionR XSectionR GhcTc
x LHsExpr GhcTc
_ LHsExpr GhcTc
_) = Void -> DsM CoreExpr
forall a. Void -> a
absurd Void
XSectionR GhcTc
x
dsExpr (HsBracket {}) = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr:HsBracket"
dsExpr (HsDo {}) = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr:HsDo"
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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
expr) CCFlavour
flavour) Bool
count Bool
True)
(CoreExpr -> CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: SyntaxExprTc -> HsExpr GhcTc
syn_expr = HsExpr GhcTc
expr
, syn_arg_wraps :: SyntaxExprTc -> [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps
, syn_res_wrap :: SyntaxExprTc -> HsWrapper
syn_res_wrap = HsWrapper
res_wrap })
[CoreExpr]
arg_exprs
= do { CoreExpr
fun <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
; [CoreExpr -> CoreExpr]
core_arg_wraps <- (HsWrapper -> 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
; IOEnv (Env DsGblEnv DsLclEnv) ()
-> (() -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs ((CoreExpr -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ())
-> [CoreExpr] -> [SDoc] -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ CoreExpr -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
dsNoLevPolyExpr [CoreExpr]
wrapped_args [ Int -> SDoc
mk_doc Int
n | Int
n <- [Int
1..] ])
(\()
_ -> CoreExpr -> CoreExpr
core_res_wrap (CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps CoreExpr
fun [CoreExpr]
wrapped_args)) }
where
mk_doc :: Int -> SDoc
mk_doc Int
n = String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
n SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"argument of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr)
dsSyntaxExpr SyntaxExpr GhcTc
SyntaxExprTc
NoSyntaxExprTc [CoreExpr]
_ = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsSyntaxExpr"
findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
findField :: forall arg. [LHsRecField GhcTc arg] -> Name -> [arg]
findField [LHsRecField GhcTc arg]
rbinds Name
sel
= [HsRecField' (FieldOcc GhcTc) arg -> arg
forall id arg. HsRecField' id arg -> arg
hsRecFieldArg HsRecField' (FieldOcc GhcTc) arg
fld | L SrcSpanAnnA
_ HsRecField' (FieldOcc GhcTc) arg
fld <- [GenLocated SrcSpanAnnA (HsRecField' (FieldOcc GhcTc) arg)]
[LHsRecField GhcTc arg]
rbinds
, Name
sel Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> Name
idName (GenLocated SrcSpan Id -> Id
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan Id -> Id) -> GenLocated SrcSpan Id -> Id
forall a b. (a -> b) -> a -> b
$ HsRecField' (FieldOcc GhcTc) arg -> GenLocated SrcSpan Id
forall arg. HsRecField GhcTc arg -> GenLocated SrcSpan Id
hsRecFieldId HsRecField' (FieldOcc GhcTc) arg
fld) ]
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 GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr
LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
[LHsExpr 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 -> ((Id, Type) -> (Id, Type) -> DsM CoreExpr) -> DsM CoreExpr
forall (m :: * -> *).
(MonadFail m, MonadThings m, MonadUnique m) =>
Type -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -> m CoreExpr
mkBuildExpr Type
elt_ty ([CoreExpr] -> (Id, Type) -> (Id, Type) -> DsM CoreExpr
forall {m :: * -> *} {t :: * -> *} {b} {b} {b}.
(Monad m, Foldable t) =>
t (Arg b) -> (Id, b) -> (Id, b) -> m (Arg b)
mk_build_list [CoreExpr]
xs') }
where
mk_build_list :: t (Arg b) -> (Id, b) -> (Id, b) -> m (Arg b)
mk_build_list t (Arg b)
xs' (Id
cons, b
_) (Id
nil, b
_)
= Arg b -> m (Arg b)
forall (m :: * -> *) a. Monad m => a -> m a
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 (Id -> Arg b
forall b. Id -> Expr b
Var Id
cons)) (Id -> Arg b
forall b. Id -> Expr b
Var Id
nil) t (Arg b)
xs')
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
dsLExprNoLP 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
dsLExprNoLP LHsExpr GhcTc
from
CoreExpr
to' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
to
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
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 GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr
LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP [GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
from, GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr 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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
thn) LHsExpr GhcTc
to
CoreExpr
expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
CoreExpr
from' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
from
CoreExpr
thn' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
thn
CoreExpr
to' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
to
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
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 :: HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsStmtContext GhcRn
ctx [ExprLStmt GhcTc]
stmts
= [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> DsM CoreExpr
goL [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[ExprLStmt 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
= ASSERT( null stmts ) dsLExpr 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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
rhs
; LHsExpr GhcTc -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDiscardedDoBindings GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
rhs (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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
rhs
; Id
var <- Type -> LPat GhcTc -> DsM Id
selectSimpleMatchVarL (XBindStmtTc -> Type
xbstc_boundResultMult XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
XBindStmtTc
xbs) LPat GhcTc
pat
; MatchResult CoreExpr
match <- Id
-> Maybe CoreExpr
-> HsMatchContext GhcRn
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar Id
var Maybe CoreExpr
forall a. Maybe a
Nothing (HsStmtContext GhcRn -> HsMatchContext GhcRn
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctx) LPat GhcTc
pat
(XBindStmtTc -> Type
xbstc_boundResultType XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
XBindStmtTc
xbs) (CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
body)
; CoreExpr
match_code <- HsStmtContext GhcRn
-> LPat GhcTc
-> MatchResult CoreExpr
-> Maybe (SyntaxExpr GhcTc)
-> DsM CoreExpr
dsHandleMonadicFailure HsStmtContext GhcRn
ctx LPat GhcTc
pat MatchResult CoreExpr
match (XBindStmtTc -> Maybe (SyntaxExpr GhcTc)
xbstc_failOp XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
XBindStmtTc
xbs)
; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (XBindStmtTc -> SyntaxExpr GhcTc
xbstc_bindOp XBindStmt GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
XBindStmtTc
xbs) [CoreExpr
rhs', Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
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) [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
[(SyntaxExprTc, ApplicativeArg GhcTc)]
args)
do_arg :: ApplicativeArg GhcTc
-> ((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc),
DsM CoreExpr)
do_arg (ApplicativeArgOne XApplicativeArgOne GhcTc
fail_op LPat GhcTc
pat LHsExpr GhcTc
expr Bool
_) =
((GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat, Maybe SyntaxExprTc
XApplicativeArgOne GhcTc
fail_op), LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr)
do_arg (ApplicativeArgMany XApplicativeArgMany GhcTc
_ [ExprLStmt GhcTc]
stmts HsExpr GhcTc
ret LPat GhcTc
pat HsStmtContext (ApplicativeArgStmCtxPass GhcTc)
_) =
((GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat, Maybe SyntaxExprTc
forall a. Maybe a
Nothing), HsStmtContext GhcRn -> [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo HsStmtContext GhcRn
ctx ([GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
[ExprLStmt 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
-> HsStmtContext (HsDoRn GhcTc)
-> XRec GhcTc [ExprLStmt GhcTc]
-> HsExpr GhcTc
forall p.
XDo p
-> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p
HsDo XApplicativeStmt
GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
XDo GhcTc
body_ty HsStmtContext GhcRn
HsStmtContext (HsDoRn GhcTc)
ctx ([GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> GenLocated
SrcSpanAnnL
[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)
-> ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
match_args (GenLocated SrcSpanAnnA (Pat GhcTc)
pat, Maybe SyntaxExprTc
fail_op) ([Id]
vs,CoreExpr
body)
= do { Id
var <- Type -> LPat GhcTc -> DsM Id
selectSimpleMatchVarL Type
Many GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat
; MatchResult CoreExpr
match <- Id
-> Maybe CoreExpr
-> HsMatchContext GhcRn
-> LPat GhcTc
-> Type
-> MatchResult CoreExpr
-> DsM (MatchResult CoreExpr)
matchSinglePatVar Id
var Maybe CoreExpr
forall a. Maybe a
Nothing (HsStmtContext GhcRn -> HsMatchContext GhcRn
forall p. HsStmtContext p -> HsMatchContext p
StmtCtxt HsStmtContext GhcRn
ctx) GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat
Type
XApplicativeStmt
GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
body_ty (CoreExpr -> MatchResult CoreExpr
cantFailMatchResult CoreExpr
body)
; CoreExpr
match_code <- HsStmtContext GhcRn
-> LPat GhcTc
-> MatchResult CoreExpr
-> Maybe (SyntaxExpr GhcTc)
-> DsM CoreExpr
dsHandleMonadicFailure HsStmtContext GhcRn
ctx GenLocated SrcSpanAnnA (Pat GhcTc)
LPat GhcTc
pat MatchResult CoreExpr
match Maybe (SyntaxExpr GhcTc)
Maybe SyntaxExprTc
fail_op
; ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
varId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
vs, CoreExpr
match_code)
}
; ([Id]
vars, CoreExpr
body) <- ((GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)
-> ([Id], CoreExpr) -> DsM ([Id], CoreExpr))
-> ([Id], CoreExpr)
-> [(GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)]
-> DsM ([Id], CoreExpr)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)
-> ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
match_args ([],CoreExpr
body') [(GenLocated SrcSpanAnnA (Pat GhcTc), Maybe SyntaxExprTc)]
pats
; let fun' :: CoreExpr
fun' = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
vars CoreExpr
body
; let mk_ap_call :: CoreExpr -> (SyntaxExprTc, CoreExpr) -> DsM CoreExpr
mk_ap_call CoreExpr
l (SyntaxExprTc
op,CoreExpr
r) = SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
SyntaxExprTc
op [CoreExpr
l,CoreExpr
r]
; CoreExpr
expr <- (CoreExpr -> (SyntaxExprTc, CoreExpr) -> DsM CoreExpr)
-> CoreExpr -> [(SyntaxExprTc, CoreExpr)] -> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CoreExpr -> (SyntaxExprTc, CoreExpr) -> DsM CoreExpr
mk_ap_call CoreExpr
fun' ([SyntaxExprTc] -> [CoreExpr] -> [(SyntaxExprTc, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((SyntaxExprTc, ApplicativeArg GhcTc) -> SyntaxExprTc)
-> [(SyntaxExprTc, ApplicativeArg GhcTc)] -> [SyntaxExprTc]
forall a b. (a -> b) -> [a] -> [b]
map (SyntaxExprTc, ApplicativeArg GhcTc) -> SyntaxExprTc
forall a b. (a, b) -> a
fst [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
[(SyntaxExprTc, ApplicativeArg GhcTc)]
args) [CoreExpr]
rhss')
; case Maybe (SyntaxExpr GhcTc)
mb_join of
Maybe (SyntaxExpr GhcTc)
Nothing -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
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 SrcSpanAnnL
_ [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
rec_stmts, recS_later_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_later_ids = [IdP GhcTc]
later_ids
, recS_rec_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_rec_ids = [IdP GhcTc]
rec_ids, recS_ret_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_ret_fn = SyntaxExpr GhcTc
return_op
, recS_mfix_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_mfix_fn = SyntaxExpr GhcTc
mfix_op, recS_bind_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_bind_fn = SyntaxExpr GhcTc
bind_op
, recS_ext :: forall idL idR body. StmtLR idL idR body -> XRecStmt idL idR body
recS_ext = RecStmtTc
{ recS_bind_ty :: RecStmtTc -> Type
recS_bind_ty = Type
bind_ty
, recS_rec_rets :: RecStmtTc -> [HsExpr GhcTc]
recS_rec_rets = [HsExpr GhcTc]
rec_rets
, recS_ret_ty :: RecStmtTc -> Type
recS_ret_ty = Type
body_ty} }) [GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (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
{ 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 [GenLocated SrcSpanAnnA (Pat GhcTc)]
[LPat GhcTc]
later_pats)
GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
mfix_app
tup_ids :: [Id]
tup_ids = [Id]
[IdP GhcTc]
rec_ids [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (IdP GhcTc -> [IdP GhcTc] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IdP GhcTc]
rec_ids) [Id]
[IdP GhcTc]
later_ids
tup_ty :: Type
tup_ty = [Type] -> Type
mkBigCoreTupTy ((Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
tup_ids)
rec_tup_pats :: [GenLocated SrcSpanAnnA (Pat GhcTc)]
rec_tup_pats = (Id -> GenLocated SrcSpanAnnA (Pat GhcTc))
-> [Id] -> [GenLocated SrcSpanAnnA (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map Id -> GenLocated SrcSpanAnnA (Pat GhcTc)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [Id]
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 SyntaxExpr GhcTc
SyntaxExprTc
mfix_op [GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr 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 { mg_alts :: XRec GhcTc [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
mg_alts = [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
-> LocatedAn
AnnList [LMatch GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))]
forall a an. a -> LocatedAn an a
noLocA [HsMatchContext (NoGhcTc 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)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch
HsMatchContext (NoGhcTc GhcTc)
forall p. HsMatchContext p
LambdaExpr
[GenLocated SrcSpanAnnA (Pat GhcTc)
LPat 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 [GenLocated SrcSpanAnnA (Pat GhcTc)]
[LPat 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
-> HsStmtContext (HsDoRn GhcTc)
-> XRec GhcTc [ExprLStmt GhcTc]
-> HsExpr GhcTc
forall p.
XDo p
-> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p
HsDo Type
XDo GhcTc
body_ty
HsStmtContext GhcRn
HsStmtContext (HsDoRn GhcTc)
ctx ([GenLocated
SrcSpanAnnA
(StmtLR GhcTc GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)))]
-> GenLocated
SrcSpanAnnL
[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 SyntaxExpr GhcTc
SyntaxExprTc
return_op [[LHsExpr GhcTc] -> LHsExpr GhcTc
mkBigLHsTupId [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
[LHsExpr 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 GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr 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 :: Id -> DsM CoreExpr
dsHsVar Id
var
= do { SDoc -> Id -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
checkLevPolyFunction (Id -> SDoc
forall {a}. Outputable a => a -> SDoc
ppr Id
var) Id
var (Id -> Type
idType Id
var)
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
var) }
dsConLike :: ConLike -> DsM CoreExpr
dsConLike :: ConLike -> DsM CoreExpr
dsConLike (RealDataCon DataCon
dc) = Id -> DsM CoreExpr
dsHsVar (DataCon -> Id
dataConWrapId DataCon
dc)
dsConLike (PatSynCon PatSyn
ps)
| Just (Name
builder_name, Type
_, Bool
add_void) <- PatSyn -> Maybe (Name, Type, Bool)
patSynBuilder PatSyn
ps
= do { Id
builder_id <- Name -> DsM Id
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)
(Id -> CoreExpr
forall b. Id -> Expr b
Var Id
builder_id) (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
voidPrimId)
else Id -> CoreExpr
forall b. Id -> Expr b
Var Id
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)
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 WarnReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnusedDoBind)
(LHsExpr GhcTc -> Type -> SDoc
badMonadBind LHsExpr GhcTc
rhs Type
elt_ty)
else
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
-> WarnReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnWrongDoBind)
(LHsExpr GhcTc -> Type -> SDoc
badMonadBind LHsExpr GhcTc
rhs Type
elt_ty)
Maybe (Type, Type)
_ -> () -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return () } }
| Bool
otherwise
= () -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
badMonadBind LHsExpr GhcTc
rhs Type
elt_ty
= [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"A do-notation statement discarded a result of type")
Int
2 (SDoc -> SDoc
quotes (Type -> SDoc
forall {a}. Outputable a => a -> SDoc
ppr Type
elt_ty))
, SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Suppress this warning by saying")
Int
2 (SDoc -> SDoc
quotes (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"_ <-" SDoc -> SDoc -> SDoc
<+> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> SDoc
forall {a}. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
rhs)
]
dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr
dsHsWrapped HsExpr GhcTc
orig_hs_expr
= (CoreExpr -> CoreExpr) -> HsExpr GhcTc -> DsM CoreExpr
go CoreExpr -> CoreExpr
forall a. a -> a
id HsExpr GhcTc
orig_hs_expr
where
go :: (CoreExpr -> CoreExpr) -> HsExpr GhcTc -> DsM CoreExpr
go CoreExpr -> CoreExpr
wrap (XExpr (WrapExpr (HsWrap HsWrapper
co_fn HsExpr GhcTc
hs_e)))
= do { CoreExpr -> CoreExpr
wrap' <- HsWrapper -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
co_fn
; Origin -> Bag Id -> DsM CoreExpr -> DsM CoreExpr
forall a. Origin -> Bag Id -> DsM a -> DsM a
addTyCs Origin
FromSource (HsWrapper -> Bag Id
hsWrapDictBinders HsWrapper
co_fn) (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
(CoreExpr -> CoreExpr) -> HsExpr GhcTc -> DsM CoreExpr
go (CoreExpr -> CoreExpr
wrap (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap') HsExpr GhcTc
hs_e }
go CoreExpr -> CoreExpr
wrap (HsConLikeOut XConLikeOut GhcTc
_ (RealDataCon DataCon
dc))
= (CoreExpr -> CoreExpr) -> Id -> DsM CoreExpr
go_head CoreExpr -> CoreExpr
wrap (DataCon -> Id
dataConWrapId DataCon
dc)
go CoreExpr -> CoreExpr
wrap (HsAppType XAppTypeE GhcTc
ty LHsExpr GhcTc
hs_e LHsWcType (NoGhcTc GhcTc)
_) = (CoreExpr -> CoreExpr)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr
go_l (CoreExpr -> CoreExpr
wrap (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\CoreExpr
e -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
e (Type -> CoreExpr
forall b. Type -> Expr b
Type Type
XAppTypeE GhcTc
ty))) GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
hs_e
go CoreExpr -> CoreExpr
wrap (HsPar XPar GhcTc
_ LHsExpr GhcTc
hs_e) = (CoreExpr -> CoreExpr)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr
go_l CoreExpr -> CoreExpr
wrap GenLocated SrcSpanAnnA (HsExpr GhcTc)
LHsExpr GhcTc
hs_e
go CoreExpr -> CoreExpr
wrap (HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Id
var)) = (CoreExpr -> CoreExpr) -> Id -> DsM CoreExpr
go_head CoreExpr -> CoreExpr
wrap Id
var
go CoreExpr -> CoreExpr
wrap HsExpr GhcTc
hs_e = 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) }
go_l :: (CoreExpr -> CoreExpr)
-> GenLocated SrcSpanAnnA (HsExpr GhcTc) -> DsM CoreExpr
go_l CoreExpr -> CoreExpr
wrap (L SrcSpanAnnA
_ HsExpr GhcTc
hs_e) = (CoreExpr -> CoreExpr) -> HsExpr GhcTc -> DsM CoreExpr
go CoreExpr -> CoreExpr
wrap HsExpr GhcTc
hs_e
go_head :: (CoreExpr -> CoreExpr) -> Id -> DsM CoreExpr
go_head CoreExpr -> CoreExpr
wrap Id
var
= do { let wrapped_e :: CoreExpr
wrapped_e = CoreExpr -> CoreExpr
wrap (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
var)
wrapped_ty :: Type
wrapped_ty = CoreExpr -> Type
exprType CoreExpr
wrapped_e
; SDoc -> Id -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
checkLevPolyFunction (HsExpr GhcTc -> SDoc
forall {a}. Outputable a => a -> SDoc
ppr HsExpr GhcTc
orig_hs_expr) Id
var Type
wrapped_ty
; DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; DynFlags -> Id -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutIdentities DynFlags
dflags Id
var Type
wrapped_ty
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
wrapped_e }
checkLevPolyFunction :: SDoc -> Id -> Type -> DsM ()
checkLevPolyFunction :: SDoc -> Id -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
checkLevPolyFunction SDoc
pp_hs_expr Id
var Type
ty
| let bad_tys :: [Type]
bad_tys = Id -> Type -> [Type]
isBadLevPolyFunction Id
var Type
ty
, Bool -> Bool
not ([Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
bad_tys)
= SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
errDs (SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ())
-> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Cannot use function with levity-polymorphic arguments:")
Int
2 (SDoc
pp_hs_expr SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprWithTYPE Type
ty)
, (SDocContext -> Bool) -> SDoc -> SDoc
ppUnlessOption SDocContext -> Bool
sdocPrintTypecheckerElaboration (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples"
, String -> SDoc
text String
"are eta-expanded internally because they must occur fully saturated."
, String -> SDoc
text String
"Use -fprint-typechecker-elaboration to display the full expression.)"
]
, SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Levity-polymorphic arguments:")
Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Type -> SDoc) -> [Type] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map
(\Type
t -> Type -> SDoc
pprWithTYPE Type
t SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprWithTYPE (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
t))
[Type]
bad_tys
]
checkLevPolyFunction SDoc
_ Id
_ Type
_ = () -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
isBadLevPolyFunction :: Id -> Type -> [Type]
isBadLevPolyFunction :: Id -> Type -> [Type]
isBadLevPolyFunction Id
id Type
ty
| Id -> Bool
hasNoBinding Id
id
= (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
isTypeLevPoly [Type]
arg_tys
| Bool
otherwise
= []
where
([TyCoBinder]
binders, Type
_) = Type -> ([TyCoBinder], Type)
splitPiTys Type
ty
arg_tys :: [Type]
arg_tys = (TyCoBinder -> Maybe Type) -> [TyCoBinder] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TyCoBinder -> Maybe Type
binderRelevantType_maybe [TyCoBinder]
binders