{-# LANGUAGE CPP, MultiWayIf #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
, dsValBinds, dsLit, dsSyntaxExpr ) where
#include "HsVersions.h"
import GhcPrelude
import Match
import MatchLit
import DsBinds
import DsGRHSs
import DsListComp
import DsUtils
import DsArrows
import DsMonad
import GHC.HsToCore.PmCheck ( checkGuardMatches )
import Name
import NameEnv
import FamInstEnv( topNormaliseType )
import DsMeta
import GHC.Hs
import TcType
import TcEvidence
import TcRnMonad
import Type
import CoreSyn
import CoreUtils
import MkCore
import DynFlags
import CostCentre
import Id
import MkId
import Module
import ConLike
import DataCon
import TyCoPpr( pprWithTYPE )
import TysWiredIn
import PrelNames
import BasicTypes
import Maybes
import VarEnv
import SrcLoc
import Util
import Bag
import Outputable
import PatSyn
import Control.Monad
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds (LHsLocalBinds GhcTc -> Located (SrcSpanLess (LHsLocalBinds GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (EmptyLocalBinds _)) CoreExpr
body = CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
body
dsLocalBinds (LHsLocalBinds GhcTc -> Located (SrcSpanLess (LHsLocalBinds GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (HsValBinds _ binds)) CoreExpr
body = SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds HsValBinds GhcTc
binds CoreExpr
body
dsLocalBinds (LHsLocalBinds GhcTc -> Located (SrcSpanLess (LHsLocalBinds GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsIPBinds _ binds)) CoreExpr
body = HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds HsIPBinds GhcTc
binds CoreExpr
body
dsLocalBinds LHsLocalBinds GhcTc
_ CoreExpr
_ = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsLocalBinds"
dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds (XValBindsLR (NValBinds binds _)) CoreExpr
body
= ((RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr)
-> CoreExpr -> [(RecFlag, LHsBinds GhcTc)] -> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
ds_val_bind CoreExpr
body [(RecFlag, LHsBinds GhcTc)]
binds
dsValBinds (ValBinds {}) CoreExpr
_ = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsValBinds ValBindsIn"
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsIPBinds (IPBinds XIPBinds GhcTc
ev_binds [LIPBind GhcTc]
ip_binds) CoreExpr
body
= do { [CoreBind]
ds_binds <- TcEvBinds -> DsM [CoreBind]
dsTcEvBinds XIPBinds GhcTc
TcEvBinds
ev_binds
; let inner :: CoreExpr
inner = [CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_binds CoreExpr
body
; (LIPBind GhcTc -> CoreExpr -> DsM CoreExpr)
-> CoreExpr -> [LIPBind GhcTc] -> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
forall a.
(HasSrcSpan a, SrcSpanLess a ~ IPBind GhcTc) =>
a -> CoreExpr -> DsM CoreExpr
ds_ip_bind CoreExpr
inner [LIPBind GhcTc]
ip_binds }
where
ds_ip_bind :: a -> CoreExpr -> DsM CoreExpr
ds_ip_bind (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (IPBind _ ~(Right n) e)) CoreExpr
body
= do CoreExpr
e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (CoreBndr -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
IdP GhcTc
n CoreExpr
e') CoreExpr
body)
ds_ip_bind a
_ CoreExpr
_ = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsIPBinds"
dsIPBinds (XHsIPBinds XXHsIPBinds GhcTc
nec) CoreExpr
_ = NoExtCon -> DsM CoreExpr
forall a. NoExtCon -> a
noExtCon XXHsIPBinds GhcTc
NoExtCon
nec
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
| [LHsBindLR GhcTc GhcTc
-> Located (SrcSpanLess (LHsBindLR GhcTc GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsBindLR GhcTc GhcTc)
bind] <- LHsBinds GhcTc -> [LHsBindLR GhcTc GhcTc]
forall a. Bag a -> [a]
bagToList LHsBinds GhcTc
hsbinds
, HsBind GhcTc -> Bool
isUnliftedHsBind SrcSpanLess (LHsBindLR GhcTc GhcTc)
HsBind GhcTc
bind
= SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
if HsBind GhcTc -> Bool
forall idL idR. HsBindLR idL idR -> Bool
is_polymorphic SrcSpanLess (LHsBindLR GhcTc GhcTc)
HsBind GhcTc
bind
then SDoc -> DsM CoreExpr
errDsCoreExpr (HsBind GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
poly_bind_err SrcSpanLess (LHsBindLR GhcTc GhcTc)
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 SrcSpanLess (LHsBindLR GhcTc GhcTc)
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 SrcSpanLess (LHsBindLR GhcTc GhcTc)
HsBind GhcTc
bind)
; HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind SrcSpanLess (LHsBindLR GhcTc GhcTc)
HsBind GhcTc
bind CoreExpr
body }
where
is_polymorphic :: HsBindLR idL idR -> Bool
is_polymorphic (AbsBinds { abs_tvs :: forall idL idR. HsBindLR idL idR -> [CoreBndr]
abs_tvs = [CoreBndr]
tvs, abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [CoreBndr]
abs_ev_vars = [CoreBndr]
evs })
= Bool -> Bool
not ([CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBndr]
tvs Bool -> Bool -> Bool
&& [CoreBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreBndr]
evs)
is_polymorphic HsBindLR idL idR
_ = Bool
False
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
| (LHsBindLR GhcTc GhcTc -> Bool) -> LHsBinds GhcTc -> Bool
forall a. (a -> Bool) -> Bag a -> Bool
anyBag (HsBind GhcTc -> Bool
isUnliftedHsBind (HsBind GhcTc -> Bool)
-> (LHsBindLR GhcTc GhcTc -> HsBind GhcTc)
-> LHsBindLR GhcTc GhcTc
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsBindLR GhcTc GhcTc -> HsBind GhcTc
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) 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 ((LHsBindLR GhcTc GhcTc -> SDoc)
-> [LHsBindLR GhcTc GhcTc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LHsBindLR GhcTc GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LHsBinds GhcTc -> [LHsBindLR GhcTc GhcTc]
forall a. Bag a -> [a]
bagToList LHsBinds GhcTc
binds)))
ds_val_bind (RecFlag
is_rec, LHsBinds GhcTc
binds) CoreExpr
body
= do { MASSERT( isRec is_rec || isSingletonBag binds )
; ([CoreBndr]
force_vars,[(CoreBndr, CoreExpr)]
prs) <- LHsBinds GhcTc -> DsM ([CoreBndr], [(CoreBndr, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
; let body' :: CoreExpr
body' = (CoreBndr -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreBndr] -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreBndr -> CoreExpr -> CoreExpr
seqVar CoreExpr
body [CoreBndr]
force_vars
; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
case [(CoreBndr, CoreExpr)]
prs of
[] -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
body
[(CoreBndr, CoreExpr)]
_ -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let ([(CoreBndr, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr, CoreExpr)]
prs) CoreExpr
body') }
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (AbsBinds { abs_tvs :: forall idL idR. HsBindLR idL idR -> [CoreBndr]
abs_tvs = [], abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [CoreBndr]
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 ~ CoreBndr) => ABExport p -> CoreExpr -> CoreExpr
bind_export CoreExpr
body [ABExport GhcTc]
exports
bind_export :: ABExport p -> CoreExpr -> CoreExpr
bind_export ABExport p
export CoreExpr
b = CoreBndr -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec (ABExport p -> IdP p
forall p. ABExport p -> IdP p
abe_poly ABExport p
export) (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var (ABExport p -> IdP p
forall p. ABExport p -> IdP p
abe_mono ABExport p
export)) CoreExpr
b
; CoreExpr
body2 <- (CoreExpr -> LHsBindLR GhcTc GhcTc -> DsM CoreExpr)
-> CoreExpr -> LHsBinds GhcTc -> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\CoreExpr
body LHsBindLR GhcTc GhcTc
lbind -> HsBind GhcTc -> CoreExpr -> DsM CoreExpr
dsUnliftedBind (LHsBindLR GhcTc GhcTc -> SrcSpanLess (LHsBindLR GhcTc GhcTc)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsBindLR GhcTc GhcTc
lbind) CoreExpr
body)
CoreExpr
body1 LHsBinds GhcTc
lbinds
; [CoreBind]
ds_binds <- [TcEvBinds] -> DsM [CoreBind]
dsTcEvBinds_s [TcEvBinds]
ev_binds
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_binds CoreExpr
body2) }
dsUnliftedBind (FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id = (Located (IdP GhcTc) -> Located (SrcSpanLess (Located CoreBndr))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l SrcSpanLess (Located CoreBndr)
fun)
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
matches
, fun_co_fn :: forall idL idR. HsBindLR idL idR -> HsWrapper
fun_co_fn = HsWrapper
co_fn
, fun_tick :: forall idL idR. HsBindLR idL idR -> [Tickish CoreBndr]
fun_tick = [Tickish CoreBndr]
tick }) CoreExpr
body
= do { ([CoreBndr]
args, CoreExpr
rhs) <- HsMatchContext Name
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([CoreBndr], CoreExpr)
matchWrapper (Located Name -> HsMatchContext Name
forall id. Located id -> HsMatchContext id
mkPrefixFunRhs (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (SrcSpanLess (Located Name) -> Located Name)
-> SrcSpanLess (Located Name) -> Located Name
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Name
idName SrcSpanLess (Located CoreBndr)
CoreBndr
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' = [Tickish CoreBndr] -> CoreExpr -> CoreExpr
mkOptTickBox [Tickish CoreBndr]
tick CoreExpr
rhs
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec SrcSpanLess (Located CoreBndr)
CoreBndr
fun CoreExpr
rhs' CoreExpr
body) }
dsUnliftedBind (PatBind {pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcTc
pat, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
grhss
, pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = NPatBindTc _ ty }) CoreExpr
body
=
do { CoreExpr
rhs <- GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
dsGuarded GRHSs GhcTc (LHsExpr GhcTc)
grhss Type
ty
; HsMatchContext Name
-> GRHSs GhcTc (LHsExpr GhcTc) -> IOEnv (Env DsGblEnv DsLclEnv) ()
checkGuardMatches HsMatchContext Name
forall id. HsMatchContext id
PatBindGuards GRHSs GhcTc (LHsExpr GhcTc)
grhss
; let upat :: SrcSpanLess (Located (Pat GhcTc))
upat = Located (Pat GhcTc) -> SrcSpanLess (Located (Pat GhcTc))
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (Pat GhcTc)
LPat GhcTc
pat
eqn :: EquationInfo
eqn = EqnInfo :: [Pat GhcTc] -> Origin -> MatchResult -> EquationInfo
EqnInfo { eqn_pats :: [Pat GhcTc]
eqn_pats = [SrcSpanLess (Located (Pat GhcTc))
Pat GhcTc
upat],
eqn_orig :: Origin
eqn_orig = Origin
FromSource,
eqn_rhs :: MatchResult
eqn_rhs = CoreExpr -> MatchResult
cantFailMatchResult CoreExpr
body }
; CoreBndr
var <- Pat GhcTc -> DsM CoreBndr
selectMatchVar SrcSpanLess (Located (Pat GhcTc))
Pat GhcTc
upat
; CoreExpr
result <- HsMatchContext Name
-> [CoreBndr] -> [EquationInfo] -> Type -> DsM CoreExpr
matchEquations HsMatchContext Name
forall id. HsMatchContext id
PatBindRhs [CoreBndr
var] [EquationInfo
eqn] (CoreExpr -> Type
exprType CoreExpr
body)
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec CoreBndr
var CoreExpr
rhs CoreExpr
result) }
dsUnliftedBind 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 (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsExpr GhcTc)
e)
= SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
do { CoreExpr
core_expr <- HsExpr GhcTc -> DsM CoreExpr
dsExpr SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
e
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
core_expr }
dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsExpr GhcTc)
e)
= SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
do { CoreExpr
e' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr SrcSpanLess (LHsExpr GhcTc)
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 SrcSpanLess (LHsExpr GhcTc)
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 = Bool -> HsExpr GhcTc -> DsM CoreExpr
ds_expr Bool
False
ds_expr :: Bool
-> HsExpr GhcTc -> DsM CoreExpr
ds_expr :: Bool -> HsExpr GhcTc -> DsM CoreExpr
ds_expr Bool
_ (HsPar XPar GhcTc
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
ds_expr Bool
_ (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
_) = LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
ds_expr Bool
w (HsVar XVar GhcTc
_ (Located (IdP GhcTc) -> Located (SrcSpanLess (Located CoreBndr))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located CoreBndr)
var)) = Bool -> CoreBndr -> DsM CoreExpr
dsHsVar Bool
w SrcSpanLess (Located CoreBndr)
CoreBndr
var
ds_expr Bool
_ (HsUnboundVar {}) = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr: HsUnboundVar"
ds_expr Bool
w (HsConLikeOut XConLikeOut GhcTc
_ ConLike
con) = Bool -> ConLike -> DsM CoreExpr
dsConLike Bool
w ConLike
con
ds_expr Bool
_ (HsIPVar {}) = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr: HsIPVar"
ds_expr Bool
_ (HsOverLabel{}) = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr: HsOverLabel"
ds_expr Bool
_ (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 a b. ConvertIdX a b => HsLit a -> HsLit b
convertLit HsLit GhcTc
lit) }
ds_expr Bool
_ (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 }
ds_expr Bool
_ (HsWrap XWrap GhcTc
_ HsWrapper
co_fn HsExpr GhcTc
e)
= do { CoreExpr
e' <- Bool -> HsExpr GhcTc -> DsM CoreExpr
ds_expr Bool
True HsExpr GhcTc
e
; CoreExpr -> CoreExpr
wrap' <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
co_fn
; DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let wrapped_e :: CoreExpr
wrapped_e = CoreExpr -> CoreExpr
wrap' CoreExpr
e'
wrapped_ty :: Type
wrapped_ty = CoreExpr -> Type
exprType CoreExpr
wrapped_e
; HsExpr GhcTc -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
checkForcedEtaExpansion HsExpr GhcTc
e Type
wrapped_ty
; DynFlags -> CoreExpr -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutIdentities DynFlags
dflags CoreExpr
e' Type
wrapped_ty
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
wrapped_e }
ds_expr Bool
_ (NegApp XNegApp GhcTc
_ (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc
(HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
SyntaxExpr GhcTc
neg_expr)
= do { CoreExpr
expr' <- SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ do
{ HsOverLit GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutOverflowedOverLit
(HsOverLit GhcTc
lit { ol_val :: OverLitVal
ol_val = IntegralLit -> OverLitVal
HsIntegral (IntegralLit -> IntegralLit
negateIntegralLit IntegralLit
i) })
; HsOverLit GhcTc -> DsM CoreExpr
dsOverLit HsOverLit GhcTc
lit }
; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
neg_expr [CoreExpr
expr'] }
ds_expr Bool
_ (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'] }
ds_expr Bool
_ (HsLam XLam GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
a_Match)
= ([CoreBndr] -> CoreExpr -> CoreExpr)
-> ([CoreBndr], CoreExpr) -> CoreExpr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [CoreBndr] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams (([CoreBndr], CoreExpr) -> CoreExpr)
-> DsM ([CoreBndr], CoreExpr) -> DsM CoreExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsMatchContext Name
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([CoreBndr], CoreExpr)
matchWrapper HsMatchContext Name
forall id. HsMatchContext id
LambdaExpr Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
a_Match
ds_expr Bool
_ (HsLamCase XLamCase GhcTc
_ MatchGroup GhcTc (LHsExpr GhcTc)
matches)
= do { ([CoreBndr
discrim_var], CoreExpr
matching_code) <- HsMatchContext Name
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([CoreBndr], CoreExpr)
matchWrapper HsMatchContext Name
forall id. HsMatchContext id
CaseAlt Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
discrim_var CoreExpr
matching_code }
ds_expr Bool
_ 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') }
ds_expr Bool
_ (HsAppType XAppTypeE GhcTc
_ LHsExpr GhcTc
e LHsWcType (NoGhcTc GhcTc)
_)
= LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
ds_expr Bool
_ e :: HsExpr GhcTc
e@(OpApp XOpApp GhcTc
_ LHsExpr GhcTc
e1 LHsExpr GhcTc
op LHsExpr GhcTc
e2)
=
do { CoreExpr
op' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
op
; DsM [CoreExpr] -> ([CoreExpr] -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs ((LHsExpr GhcTc -> DsM CoreExpr)
-> [LHsExpr GhcTc] -> DsM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP [LHsExpr GhcTc
e1, LHsExpr GhcTc
e2])
(\[CoreExpr]
exprs' -> SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs (String -> SDoc
text String
"opapp" SDoc -> SDoc -> SDoc
<+> HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
e) CoreExpr
op' [CoreExpr]
exprs') }
ds_expr Bool
_ (SectionL XSectionL GhcTc
_ LHsExpr GhcTc
expr LHsExpr GhcTc
op)
= do { CoreExpr
op' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
op
; DsM CoreExpr -> (CoreExpr -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs (LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
expr)
(\CoreExpr
expr' -> SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs (String -> SDoc
text String
"sectionl" SDoc -> SDoc -> SDoc
<+> LHsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcTc
expr) CoreExpr
op' CoreExpr
expr') }
ds_expr Bool
_ e :: HsExpr GhcTc
e@(SectionR XSectionR GhcTc
_ LHsExpr GhcTc
op LHsExpr GhcTc
expr) = do
CoreExpr
core_op <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
op
let (Type
x_ty:Type
y_ty:[Type]
_, Type
_) = Type -> ([Type], Type)
splitFunTys (CoreExpr -> Type
exprType CoreExpr
core_op)
CoreExpr
y_core <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
DsM [CoreBndr] -> ([CoreBndr] -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs ((Type -> DsM CoreBndr) -> [Type] -> DsM [CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM CoreBndr
newSysLocalDsNoLP [Type
x_ty, Type
y_ty])
(\[CoreBndr
x_id, CoreBndr
y_id] -> CoreBndr -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec CoreBndr
y_id CoreExpr
y_core (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x_id (SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreAppsDs (String -> SDoc
text String
"sectionr" SDoc -> SDoc -> SDoc
<+> HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
e)
CoreExpr
core_op [CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
x_id, CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
y_id]))
ds_expr Bool
_ (ExplicitTuple XExplicitTuple GhcTc
_ [LHsTupArg GhcTc]
tup_args Boxity
boxity)
= do { let go :: ([CoreBndr], [CoreExpr])
-> a -> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr])
go ([CoreBndr]
lam_vars, [CoreExpr]
args) (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Missing ty))
= do { CoreBndr
lam_var <- Type -> DsM CoreBndr
newSysLocalDsNoLP Type
XMissing GhcTc
ty
; ([CoreBndr], [CoreExpr])
-> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr])
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr
lam_var CoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
: [CoreBndr]
lam_vars, CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
lam_var CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args) }
go ([CoreBndr]
lam_vars, [CoreExpr]
args) (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Present _ expr))
= do { CoreExpr
core_expr <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
expr
; ([CoreBndr], [CoreExpr])
-> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr])
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreBndr]
lam_vars, CoreExpr
core_expr CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
args) }
go ([CoreBndr], [CoreExpr])
_ a
_ = String -> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr])
forall a. String -> a
panic String
"ds_expr"
; IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr])
-> (([CoreBndr], [CoreExpr]) -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs ((([CoreBndr], [CoreExpr])
-> LHsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr]))
-> ([CoreBndr], [CoreExpr])
-> [LHsTupArg GhcTc]
-> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([CoreBndr], [CoreExpr])
-> LHsTupArg GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr])
forall a.
(HasSrcSpan a, SrcSpanLess a ~ HsTupArg GhcTc) =>
([CoreBndr], [CoreExpr])
-> a -> IOEnv (Env DsGblEnv DsLclEnv) ([CoreBndr], [CoreExpr])
go ([], []) ([LHsTupArg GhcTc] -> [LHsTupArg GhcTc]
forall a. [a] -> [a]
reverse [LHsTupArg GhcTc]
tup_args))
(\([CoreBndr]
lam_vars, [CoreExpr]
args) -> [CoreBndr] -> CoreExpr -> CoreExpr
mkCoreLams [CoreBndr]
lam_vars (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
Boxity -> [CoreExpr] -> CoreExpr
mkCoreTupBoxity Boxity
boxity [CoreExpr]
args) }
ds_expr Bool
_ (ExplicitSum XExplicitSum GhcTc
types Int
alt Int
arity LHsExpr GhcTc
expr)
= do { DsM CoreExpr -> (CoreExpr -> CoreExpr) -> DsM CoreExpr
forall a. DsM a -> (a -> CoreExpr) -> DsM CoreExpr
dsWhenNoErrs (LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
expr)
(\CoreExpr
core_expr -> DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps (Int -> Int -> DataCon
sumDataCon Int
alt Int
arity)
((Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> CoreExpr
forall b. Type -> Expr b
Type (Type -> CoreExpr) -> (Type -> Type) -> Type -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep) [Type]
XExplicitSum GhcTc
types [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++
(Type -> CoreExpr) -> [Type] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map Type -> CoreExpr
forall b. Type -> Expr b
Type [Type]
XExplicitSum GhcTc
types [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++
[CoreExpr
core_expr]) ) }
ds_expr Bool
_ (HsSCC XSCC GhcTc
_ SourceText
_ StringLiteral
cc expr :: LHsExpr GhcTc
expr@(LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsExpr GhcTc)
_)) = do
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags
then do
Module
mod_name <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
Bool
count <- GeneralFlag -> TcRnIf DsGblEnv DsLclEnv Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
Opt_ProfCountEntries
let nm :: FastString
nm = StringLiteral -> FastString
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
<$> FastString -> IOEnv (Env DsGblEnv DsLclEnv) CostCentreIndex
forall gbl lcl.
ContainsCostCentreState gbl =>
FastString -> TcRnIf gbl lcl CostCentreIndex
getCCIndexM FastString
nm
Tickish CoreBndr -> CoreExpr -> CoreExpr
forall b. Tickish CoreBndr -> Expr b -> Expr b
Tick (CostCentre -> Bool -> Bool -> Tickish CoreBndr
forall id. CostCentre -> Bool -> Bool -> Tickish id
ProfNote (FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC FastString
nm Module
mod_name SrcSpan
loc 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
ds_expr Bool
_ (HsCoreAnn XCoreAnn GhcTc
_ SourceText
_ StringLiteral
_ LHsExpr GhcTc
expr)
= LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
ds_expr Bool
_ (HsCase XCase GhcTc
_ LHsExpr GhcTc
discrim MatchGroup GhcTc (LHsExpr GhcTc)
matches)
= do { CoreExpr
core_discrim <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
discrim
; ([CoreBndr
discrim_var], CoreExpr
matching_code) <- HsMatchContext Name
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([CoreBndr], CoreExpr)
matchWrapper HsMatchContext Name
forall id. HsMatchContext id
CaseAlt (LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
forall a. a -> Maybe a
Just LHsExpr GhcTc
discrim) MatchGroup GhcTc (LHsExpr GhcTc)
matches
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec CoreBndr
discrim_var CoreExpr
core_discrim CoreExpr
matching_code) }
ds_expr Bool
_ (HsLet XLet GhcTc
_ LHsLocalBinds GhcTc
binds LHsExpr GhcTc
body) = do
CoreExpr
body' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
body
LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds LHsLocalBinds GhcTc
binds CoreExpr
body'
ds_expr Bool
_ (HsDo XDo GhcTc
res_ty HsStmtContext Name
ListComp (Located [ExprLStmt GhcTc]
-> Located (SrcSpanLess (Located [ExprLStmt GhcTc]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located [ExprLStmt GhcTc])
stmts)) = [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
dsListComp [ExprLStmt GhcTc]
SrcSpanLess (Located [ExprLStmt GhcTc])
stmts Type
XDo GhcTc
res_ty
ds_expr Bool
_ (HsDo XDo GhcTc
_ HsStmtContext Name
DoExpr (Located [ExprLStmt GhcTc]
-> Located (SrcSpanLess (Located [ExprLStmt GhcTc]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located [ExprLStmt GhcTc])
stmts)) = [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo [ExprLStmt GhcTc]
SrcSpanLess (Located [ExprLStmt GhcTc])
stmts
ds_expr Bool
_ (HsDo XDo GhcTc
_ HsStmtContext Name
GhciStmtCtxt (Located [ExprLStmt GhcTc]
-> Located (SrcSpanLess (Located [ExprLStmt GhcTc]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located [ExprLStmt GhcTc])
stmts)) = [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo [ExprLStmt GhcTc]
SrcSpanLess (Located [ExprLStmt GhcTc])
stmts
ds_expr Bool
_ (HsDo XDo GhcTc
_ HsStmtContext Name
MDoExpr (Located [ExprLStmt GhcTc]
-> Located (SrcSpanLess (Located [ExprLStmt GhcTc]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located [ExprLStmt GhcTc])
stmts)) = [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo [ExprLStmt GhcTc]
SrcSpanLess (Located [ExprLStmt GhcTc])
stmts
ds_expr Bool
_ (HsDo XDo GhcTc
_ HsStmtContext Name
MonadComp (Located [ExprLStmt GhcTc]
-> Located (SrcSpanLess (Located [ExprLStmt GhcTc]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located [ExprLStmt GhcTc])
stmts)) = [ExprLStmt GhcTc] -> DsM CoreExpr
dsMonadComp [ExprLStmt GhcTc]
SrcSpanLess (Located [ExprLStmt GhcTc])
stmts
ds_expr Bool
_ (HsIf XIf GhcTc
_ Maybe (SyntaxExpr GhcTc)
mb_fun LHsExpr GhcTc
guard_expr LHsExpr GhcTc
then_expr LHsExpr GhcTc
else_expr)
= do { CoreExpr
pred <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
guard_expr
; CoreExpr
b1 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
then_expr
; CoreExpr
b2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
else_expr
; case Maybe (SyntaxExpr GhcTc)
mb_fun of
Just SyntaxExpr GhcTc
fun -> SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
fun [CoreExpr
pred, CoreExpr
b1, CoreExpr
b2]
Maybe (SyntaxExpr GhcTc)
Nothing -> 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 }
ds_expr Bool
_ (HsMultiIf XMultiIf GhcTc
res_ty [LGRHS GhcTc (LHsExpr GhcTc)]
alts)
| [LGRHS GhcTc (LHsExpr GhcTc)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LGRHS GhcTc (LHsExpr GhcTc)]
alts
= DsM CoreExpr
mkErrorExpr
| Bool
otherwise
= do { MatchResult
match_result <- ([MatchResult] -> MatchResult)
-> IOEnv (Env DsGblEnv DsLclEnv) [MatchResult]
-> IOEnv (Env DsGblEnv DsLclEnv) MatchResult
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((MatchResult -> MatchResult -> MatchResult)
-> [MatchResult] -> MatchResult
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 MatchResult -> MatchResult -> MatchResult
combineMatchResults)
((LGRHS GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) MatchResult)
-> [LGRHS GhcTc (LHsExpr GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) [MatchResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HsMatchContext Name
-> Type
-> LGRHS GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) MatchResult
dsGRHS HsMatchContext Name
forall id. HsMatchContext id
IfAlt Type
XMultiIf GhcTc
res_ty) [LGRHS GhcTc (LHsExpr GhcTc)]
alts)
; HsMatchContext Name
-> GRHSs GhcTc (LHsExpr GhcTc) -> IOEnv (Env DsGblEnv DsLclEnv) ()
checkGuardMatches HsMatchContext Name
forall id. HsMatchContext id
IfAlt (XCGRHSs GhcTc (LHsExpr GhcTc)
-> [LGRHS GhcTc (LHsExpr GhcTc)]
-> LHsLocalBinds GhcTc
-> GRHSs GhcTc (LHsExpr GhcTc)
forall p body.
XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body
GRHSs XCGRHSs GhcTc (LHsExpr GhcTc)
NoExtField
noExtField [LGRHS GhcTc (LHsExpr GhcTc)]
alts (SrcSpanLess (LHsLocalBinds GhcTc) -> LHsLocalBinds GhcTc
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsLocalBinds GhcTc)
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds))
; CoreExpr
error_expr <- DsM CoreExpr
mkErrorExpr
; MatchResult -> CoreExpr -> DsM CoreExpr
extractMatchResult MatchResult
match_result CoreExpr
error_expr }
where
mkErrorExpr :: DsM CoreExpr
mkErrorExpr = CoreBndr -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs CoreBndr
nON_EXHAUSTIVE_GUARDS_ERROR_ID Type
XMultiIf GhcTc
res_ty
(String -> SDoc
text String
"multi-way if")
ds_expr Bool
_ (ExplicitList XExplicitList GhcTc
elt_ty Maybe (SyntaxExpr GhcTc)
wit [LHsExpr GhcTc]
xs)
= Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> DsM CoreExpr
dsExplicitList Type
XExplicitList GhcTc
elt_ty Maybe (SyntaxExpr GhcTc)
wit [LHsExpr GhcTc]
xs
ds_expr Bool
_ (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] }
ds_expr Bool
_ (HsStatic XStatic GhcTc
_ expr :: LHsExpr GhcTc
expr@(LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsExpr GhcTc)
_)) = do
CoreExpr
expr_ds <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
expr
let ty :: Type
ty = CoreExpr -> Type
exprType CoreExpr
expr_ds
CoreBndr
makeStaticId <- Name -> DsM CoreBndr
dsLookupGlobalId Name
makeStaticName
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let (Int
line, Int
col) = case SrcSpan
loc of
RealSrcSpan RealSrcSpan
r -> ( 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
, DynFlags -> Int -> CoreExpr
mkIntExprInt DynFlags
dflags Int
line, DynFlags -> Int -> CoreExpr
mkIntExprInt DynFlags
dflags Int
col
]
SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
makeStaticId) [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty, CoreExpr
srcLoc, CoreExpr
expr_ds ]
ds_expr Bool
_ (RecordCon { rcon_flds :: forall p. HsExpr p -> HsRecordBinds p
rcon_flds = HsRecordBinds GhcTc
rbinds
, rcon_ext :: forall p. HsExpr p -> XRecordCon p
rcon_ext = RecordConTc { rcon_con_expr = con_expr
, rcon_con_like = con_like }})
= do { CoreExpr
con_expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
con_expr
; let
([Type]
arg_tys, Type
_) = Type -> ([Type], Type)
tcSplitFunTys (CoreExpr -> Type
exprType CoreExpr
con_expr')
mk_arg :: (Type, FieldLbl Name) -> DsM CoreExpr
mk_arg (Type
arg_ty, FieldLbl Name
fl)
= case [LHsRecField GhcTc (LHsExpr GhcTc)] -> Name -> [LHsExpr GhcTc]
forall arg. [LHsRecField GhcTc arg] -> Name -> [arg]
findField (HsRecordBinds GhcTc -> [LHsRecField GhcTc (LHsExpr GhcTc)]
forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_flds HsRecordBinds GhcTc
rbinds) (FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector FieldLbl Name
fl) of
(LHsExpr GhcTc
rhs:[LHsExpr GhcTc]
rhss) -> ASSERT( null rhss )
LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
rhs
[] -> CoreBndr -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs CoreBndr
rEC_CON_ERROR_ID Type
arg_ty (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FieldLbl Name -> FastString
forall a. FieldLbl a -> FastString
flLabel FieldLbl Name
fl))
unlabelled_bottom :: Type -> DsM CoreExpr
unlabelled_bottom Type
arg_ty = CoreBndr -> Type -> SDoc -> DsM CoreExpr
mkErrorAppDs CoreBndr
rEC_CON_ERROR_ID Type
arg_ty SDoc
Outputable.empty
labels :: [FieldLbl Name]
labels = ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con_like
; [CoreExpr]
con_args <- if [FieldLbl Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldLbl Name]
labels
then (Type -> DsM CoreExpr) -> [Type] -> DsM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM CoreExpr
unlabelled_bottom [Type]
arg_tys
else ((Type, FieldLbl Name) -> DsM CoreExpr)
-> [(Type, FieldLbl Name)] -> DsM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type, FieldLbl Name) -> DsM CoreExpr
mk_arg (String -> [Type] -> [FieldLbl Name] -> [(Type, FieldLbl Name)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"dsExpr:RecordCon" [Type]
arg_tys [FieldLbl Name]
labels)
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> [CoreExpr] -> CoreExpr
mkCoreApps CoreExpr
con_expr' [CoreExpr]
con_args) }
ds_expr Bool
_ expr :: HsExpr GhcTc
expr@(RecordUpd { rupd_expr :: forall p. HsExpr p -> LHsExpr p
rupd_expr = LHsExpr GhcTc
record_expr, rupd_flds :: forall p. HsExpr p -> [LHsRecUpdField p]
rupd_flds = [LHsRecUpdField GhcTc]
fields
, rupd_ext :: forall p. HsExpr p -> XRecordUpd p
rupd_ext = RecordUpdTc
{ rupd_cons = cons_to_upd
, rupd_in_tys = in_inst_tys
, rupd_out_tys = out_inst_tys
, rupd_wrap = dict_req_wrap }} )
| [LHsRecUpdField GhcTc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsRecUpdField GhcTc]
fields
= LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
record_expr
| Bool
otherwise
= ASSERT2( notNull cons_to_upd, ppr expr )
do { CoreExpr
record_expr' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
record_expr
; [(Name, CoreBndr, CoreExpr)]
field_binds' <- (LHsRecUpdField GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, CoreBndr, CoreExpr))
-> [LHsRecUpdField GhcTc]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Name, CoreBndr, CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsRecUpdField GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, CoreBndr, CoreExpr)
ds_field [LHsRecUpdField GhcTc]
fields
; let upd_fld_env :: NameEnv Id
upd_fld_env :: NameEnv CoreBndr
upd_fld_env = [(Name, CoreBndr)] -> NameEnv CoreBndr
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name
f,CoreBndr
l) | (Name
f,CoreBndr
l,CoreExpr
_) <- [(Name, CoreBndr, CoreExpr)]
field_binds']
; [LMatch GhcTc (LHsExpr GhcTc)]
alts <- (ConLike
-> IOEnv (Env DsGblEnv DsLclEnv) (LMatch GhcTc (LHsExpr GhcTc)))
-> [ConLike]
-> IOEnv (Env DsGblEnv DsLclEnv) [LMatch GhcTc (LHsExpr GhcTc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NameEnv CoreBndr
-> ConLike
-> IOEnv (Env DsGblEnv DsLclEnv) (LMatch GhcTc (LHsExpr GhcTc))
mk_alt NameEnv CoreBndr
upd_fld_env) [ConLike]
cons_to_upd
; ([CoreBndr
discrim_var], CoreExpr
matching_code)
<- HsMatchContext Name
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([CoreBndr], CoreExpr)
matchWrapper HsMatchContext Name
forall id. HsMatchContext id
RecUpd Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing
(MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG { mg_alts :: Located [LMatch GhcTc (LHsExpr GhcTc)]
mg_alts = SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
-> Located [LMatch GhcTc (LHsExpr GhcTc)]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [LMatch GhcTc (LHsExpr GhcTc)]
SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
alts
, mg_ext :: XMG GhcTc (LHsExpr GhcTc)
mg_ext = [Type] -> Type -> MatchGroupTc
MatchGroupTc [Type
in_ty] Type
out_ty
, mg_origin :: Origin
mg_origin = Origin
FromSource })
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
forall a. [(a, CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [(Name, CoreBndr, CoreExpr)]
field_binds' (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreBndr -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec CoreBndr
discrim_var CoreExpr
record_expr' CoreExpr
matching_code) }
where
ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
ds_field :: LHsRecUpdField GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, CoreBndr, CoreExpr)
ds_field (LHsRecUpdField GhcTc
-> Located (SrcSpanLess (LHsRecUpdField GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LHsRecUpdField GhcTc)
rec_field)
= do { CoreExpr
rhs <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr (HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcTc)
-> LHsExpr GhcTc
forall id arg. HsRecField' id arg -> arg
hsRecFieldArg SrcSpanLess (LHsRecUpdField GhcTc)
HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcTc)
rec_field)
; let fld_id :: SrcSpanLess (Located CoreBndr)
fld_id = Located CoreBndr -> SrcSpanLess (Located CoreBndr)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcTc)
-> Located CoreBndr
forall arg.
HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located CoreBndr
hsRecUpdFieldId SrcSpanLess (LHsRecUpdField GhcTc)
HsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcTc)
rec_field)
; CoreBndr
lcl_id <- Type -> DsM CoreBndr
newSysLocalDs (CoreBndr -> Type
idType SrcSpanLess (Located CoreBndr)
CoreBndr
fld_id)
; (Name, CoreBndr, CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (Name, CoreBndr, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> Name
idName SrcSpanLess (Located CoreBndr)
CoreBndr
fld_id, CoreBndr
lcl_id, CoreExpr
rhs) }
add_field_binds :: [(a, CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [] CoreExpr
expr = CoreExpr
expr
add_field_binds ((a
_,CoreBndr
b,CoreExpr
r):[(a, CoreBndr, CoreExpr)]
bs) CoreExpr
expr = CoreBndr -> CoreExpr -> CoreExpr -> CoreExpr
bindNonRec CoreBndr
b CoreExpr
r ([(a, CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
add_field_binds [(a, CoreBndr, CoreExpr)]
bs CoreExpr
expr)
(Type
in_ty, Type
out_ty) =
case ([ConLike] -> ConLike
forall a. [a] -> a
head [ConLike]
cons_to_upd) of
RealDataCon DataCon
data_con ->
let tycon :: TyCon
tycon = DataCon -> TyCon
dataConTyCon DataCon
data_con in
(TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type]
in_inst_tys, TyCon -> [Type] -> Type
mkFamilyTyConApp TyCon
tycon [Type]
out_inst_tys)
PatSynCon PatSyn
pat_syn ->
( PatSyn -> [Type] -> Type
patSynInstResTy PatSyn
pat_syn [Type]
in_inst_tys
, PatSyn -> [Type] -> Type
patSynInstResTy PatSyn
pat_syn [Type]
out_inst_tys)
mk_alt :: NameEnv CoreBndr
-> ConLike
-> IOEnv (Env DsGblEnv DsLclEnv) (LMatch GhcTc (LHsExpr GhcTc))
mk_alt NameEnv CoreBndr
upd_fld_env ConLike
con
= do { let ([CoreBndr]
univ_tvs, [CoreBndr]
ex_tvs, [EqSpec]
eq_spec,
[Type]
prov_theta, [Type]
_req_theta, [Type]
arg_tys, Type
_) = ConLike
-> ([CoreBndr], [CoreBndr], [EqSpec], [Type], [Type], [Type], Type)
conLikeFullSig ConLike
con
user_tvs :: [CoreBndr]
user_tvs =
case ConLike
con of
RealDataCon DataCon
data_con -> DataCon -> [CoreBndr]
dataConUserTyVars DataCon
data_con
PatSynCon PatSyn
_ -> [CoreBndr]
univ_tvs [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ [CoreBndr]
ex_tvs
in_subst :: TCvSubst
in_subst = [CoreBndr] -> [Type] -> TCvSubst
HasDebugCallStack => [CoreBndr] -> [Type] -> TCvSubst
zipTvSubst [CoreBndr]
univ_tvs [Type]
in_inst_tys
out_subst :: TCvSubst
out_subst = [CoreBndr] -> [Type] -> TCvSubst
HasDebugCallStack => [CoreBndr] -> [Type] -> TCvSubst
zipTvSubst [CoreBndr]
univ_tvs [Type]
out_inst_tys
; [CoreBndr]
eqs_vars <- (Type -> DsM CoreBndr) -> [Type] -> DsM [CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM CoreBndr
newPredVarDs (HasCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
in_subst ([EqSpec] -> [Type]
eqSpecPreds [EqSpec]
eq_spec))
; [CoreBndr]
theta_vars <- (Type -> DsM CoreBndr) -> [Type] -> DsM [CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> DsM CoreBndr
newPredVarDs (HasCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
in_subst [Type]
prov_theta)
; [CoreBndr]
arg_ids <- [Type] -> DsM [CoreBndr]
newSysLocalsDs (TCvSubst -> [Type] -> [Type]
substTysUnchecked TCvSubst
in_subst [Type]
arg_tys)
; let field_labels :: [FieldLbl Name]
field_labels = ConLike -> [FieldLbl Name]
conLikeFieldLabels ConLike
con
val_args :: [LHsExpr GhcTc]
val_args = String
-> (FieldLbl Name -> CoreBndr -> LHsExpr GhcTc)
-> [FieldLbl Name]
-> [CoreBndr]
-> [LHsExpr GhcTc]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"dsExpr:RecordUpd" FieldLbl Name -> CoreBndr -> LHsExpr GhcTc
mk_val_arg
[FieldLbl Name]
field_labels [CoreBndr]
arg_ids
mk_val_arg :: FieldLbl Name -> CoreBndr -> LHsExpr GhcTc
mk_val_arg FieldLbl Name
fl CoreBndr
pat_arg_id
= IdP GhcTc -> LHsExpr GhcTc
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (NameEnv CoreBndr -> Name -> Maybe CoreBndr
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv CoreBndr
upd_fld_env (FieldLbl Name -> Name
forall a. FieldLbl a -> a
flSelector FieldLbl Name
fl) Maybe CoreBndr -> CoreBndr -> CoreBndr
forall a. Maybe a -> a -> a
`orElse` CoreBndr
pat_arg_id)
inst_con :: LHsExpr GhcTc
inst_con = SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc)
-> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
forall (id :: Pass).
HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap HsWrapper
wrap (XConLikeOut GhcTc -> ConLike -> HsExpr GhcTc
forall p. XConLikeOut p -> ConLike -> HsExpr p
HsConLikeOut XConLikeOut GhcTc
NoExtField
noExtField ConLike
con)
wrap :: HsWrapper
wrap = [CoreBndr] -> HsWrapper
mkWpEvVarApps [CoreBndr]
theta_vars HsWrapper -> HsWrapper -> HsWrapper
<.>
HsWrapper
dict_req_wrap HsWrapper -> HsWrapper -> HsWrapper
<.>
[Type] -> HsWrapper
mkWpTyApps [ TCvSubst -> CoreBndr -> Maybe Type
lookupTyVar TCvSubst
out_subst CoreBndr
tv
Maybe Type -> Type -> Type
forall a. Maybe a -> a -> a
`orElse` CoreBndr -> Type
mkTyVarTy CoreBndr
tv
| CoreBndr
tv <- [CoreBndr]
user_tvs
, Bool -> Bool
not (CoreBndr
tv CoreBndr -> VarEnv TcCoercion -> Bool
forall a. CoreBndr -> VarEnv a -> Bool
`elemVarEnv` VarEnv TcCoercion
wrap_subst) ]
rhs :: LHsExpr GhcTc
rhs = (LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc)
-> LHsExpr GhcTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\LHsExpr GhcTc
a LHsExpr GhcTc
b -> LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcTc
a LHsExpr GhcTc
b) LHsExpr GhcTc
inst_con [LHsExpr GhcTc]
val_args
wrapped_rhs :: LHsExpr GhcTc
wrapped_rhs =
case ConLike
con of
RealDataCon DataCon
data_con ->
let
wrap_co :: TcCoercion
wrap_co =
Role -> TyCon -> [TcCoercion] -> TcCoercion
mkTcTyConAppCo Role
Nominal
(DataCon -> TyCon
dataConTyCon DataCon
data_con)
[ CoreBndr -> Type -> TcCoercion
lookup CoreBndr
tv Type
ty
| (CoreBndr
tv,Type
ty) <- [CoreBndr]
univ_tvs [CoreBndr] -> [Type] -> [(CoreBndr, Type)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Type]
out_inst_tys ]
lookup :: CoreBndr -> Type -> TcCoercion
lookup CoreBndr
univ_tv Type
ty =
case VarEnv TcCoercion -> CoreBndr -> Maybe TcCoercion
forall a. VarEnv a -> CoreBndr -> Maybe a
lookupVarEnv VarEnv TcCoercion
wrap_subst CoreBndr
univ_tv of
Just TcCoercion
co' -> TcCoercion
co'
Maybe TcCoercion
Nothing -> Role -> Type -> TcCoercion
mkTcReflCo Role
Nominal Type
ty
in if [EqSpec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EqSpec]
eq_spec
then LHsExpr GhcTc
rhs
else HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
forall (id :: Pass).
HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap (TcCoercion -> HsWrapper
mkWpCastN TcCoercion
wrap_co) LHsExpr GhcTc
rhs
PatSynCon PatSyn
_ -> LHsExpr GhcTc
rhs
wrap_subst :: VarEnv TcCoercion
wrap_subst =
[(CoreBndr, TcCoercion)] -> VarEnv TcCoercion
forall a. [(CoreBndr, a)] -> VarEnv a
mkVarEnv [ (CoreBndr
tv, TcCoercion -> TcCoercion
mkTcSymCo (CoreBndr -> TcCoercion
mkTcCoVarCo CoreBndr
eq_var))
| (EqSpec
spec, CoreBndr
eq_var) <- [EqSpec]
eq_spec [EqSpec] -> [CoreBndr] -> [(EqSpec, CoreBndr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CoreBndr]
eqs_vars
, let tv :: CoreBndr
tv = EqSpec -> CoreBndr
eqSpecTyVar EqSpec
spec ]
req_wrap :: HsWrapper
req_wrap = HsWrapper
dict_req_wrap HsWrapper -> HsWrapper -> HsWrapper
<.> [Type] -> HsWrapper
mkWpTyApps [Type]
in_inst_tys
pat :: Located (Pat GhcTc)
pat = SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc))
-> SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$ ConPatOut :: forall p.
Located ConLike
-> [Type]
-> [CoreBndr]
-> [CoreBndr]
-> TcEvBinds
-> HsConPatDetails p
-> HsWrapper
-> Pat p
ConPatOut { pat_con :: Located ConLike
pat_con = SrcSpanLess (Located ConLike) -> Located ConLike
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located ConLike)
ConLike
con
, pat_tvs :: [CoreBndr]
pat_tvs = [CoreBndr]
ex_tvs
, pat_dicts :: [CoreBndr]
pat_dicts = [CoreBndr]
eqs_vars [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ [CoreBndr]
theta_vars
, pat_binds :: TcEvBinds
pat_binds = TcEvBinds
emptyTcEvBinds
, pat_args :: HsConPatDetails GhcTc
pat_args = [Located (Pat GhcTc)]
-> HsConDetails
(Located (Pat GhcTc)) (HsRecFields GhcTc (Located (Pat GhcTc)))
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ([Located (Pat GhcTc)]
-> HsConDetails
(Located (Pat GhcTc)) (HsRecFields GhcTc (Located (Pat GhcTc))))
-> [Located (Pat GhcTc)]
-> HsConDetails
(Located (Pat GhcTc)) (HsRecFields GhcTc (Located (Pat GhcTc)))
forall a b. (a -> b) -> a -> b
$ (CoreBndr -> Located (Pat GhcTc))
-> [CoreBndr] -> [Located (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> Located (Pat GhcTc)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat [CoreBndr]
arg_ids
, pat_arg_tys :: [Type]
pat_arg_tys = [Type]
in_inst_tys
, pat_wrap :: HsWrapper
pat_wrap = HsWrapper
req_wrap }
; LMatch GhcTc (LHsExpr GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) (LMatch GhcTc (LHsExpr GhcTc))
forall (m :: * -> *) a. Monad m => a -> m a
return (HsMatchContext (NameOrRdrName (IdP GhcTc))
-> [LPat GhcTc] -> LHsExpr GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch HsMatchContext (NameOrRdrName (IdP GhcTc))
forall id. HsMatchContext id
RecUpd [Located (Pat GhcTc)
LPat GhcTc
pat] LHsExpr GhcTc
wrapped_rhs) }
ds_expr Bool
_ (HsRnBracketOut XRnBracketOut GhcTc
_ HsBracket GhcRn
_ [PendingRnSplice]
_) = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr HsRnBracketOut"
ds_expr Bool
_ (HsTcBracketOut XTcBracketOut GhcTc
_ HsBracket GhcRn
x [PendingTcSplice]
ps) = HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr
dsBracket HsBracket GhcRn
x [PendingTcSplice]
ps
ds_expr Bool
_ (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)
ds_expr Bool
_ (HsProc XProc GhcTc
_ LPat GhcTc
pat LHsCmdTop GhcTc
cmd) = LPat GhcTc -> LHsCmdTop GhcTc -> DsM CoreExpr
dsProcExpr LPat GhcTc
pat LHsCmdTop GhcTc
cmd
ds_expr Bool
_ (HsTick XTick GhcTc
_ Tickish (IdP GhcTc)
tickish LHsExpr GhcTc
e) = do
CoreExpr
e' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
e
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Tickish CoreBndr -> CoreExpr -> CoreExpr
forall b. Tickish CoreBndr -> Expr b -> Expr b
Tick Tickish CoreBndr
Tickish (IdP GhcTc)
tickish CoreExpr
e')
ds_expr Bool
_ (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
}
ds_expr Bool
_ (HsTickPragma XTickPragma GhcTc
_ SourceText
_ (StringLiteral, (Int, Int), (Int, Int))
_ ((SourceText, SourceText), (SourceText, SourceText))
_ LHsExpr GhcTc
expr) = do
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Hpc DynFlags
dflags
then String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr:HsTickPragma"
else LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
ds_expr Bool
_ (HsBracket {}) = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr:HsBracket"
ds_expr Bool
_ (HsDo {}) = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr:HsDo"
ds_expr Bool
_ (HsRecFld {}) = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsExpr:HsRecFld"
ds_expr Bool
_ (XExpr XXExpr GhcTc
nec) = NoExtCon -> DsM CoreExpr
forall a. NoExtCon -> a
noExtCon XXExpr GhcTc
NoExtCon
nec
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (SyntaxExpr { syn_expr :: forall p. SyntaxExpr p -> HsExpr p
syn_expr = HsExpr GhcTc
expr
, syn_arg_wraps :: forall p. SyntaxExpr p -> [HsWrapper]
syn_arg_wraps = [HsWrapper]
arg_wraps
, syn_res_wrap :: forall p. SyntaxExpr p -> HsWrapper
syn_res_wrap = HsWrapper
res_wrap })
[CoreExpr]
arg_exprs
= do { CoreExpr
fun <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
; [CoreExpr -> CoreExpr]
core_arg_wraps <- (HsWrapper -> DsM (CoreExpr -> CoreExpr))
-> [HsWrapper]
-> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr -> CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper [HsWrapper]
arg_wraps
; CoreExpr -> CoreExpr
core_res_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
res_wrap
; let wrapped_args :: [CoreExpr]
wrapped_args = ((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> [CoreExpr -> CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (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
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
fun [CoreExpr]
wrapped_args)) }
where
mk_doc :: Int -> SDoc
mk_doc Int
n = String -> SDoc
text String
"In the" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakNth Int
n SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"argument of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
expr)
findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
findField [LHsRecField GhcTc arg]
rbinds Name
sel
= [HsRecField' (FieldOcc GhcTc) arg -> arg
forall id arg. HsRecField' id arg -> arg
hsRecFieldArg SrcSpanLess (LHsRecField GhcTc arg)
HsRecField' (FieldOcc GhcTc) arg
fld | (LHsRecField GhcTc arg
-> Located (SrcSpanLess (LHsRecField GhcTc arg))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LHsRecField GhcTc arg)
fld) <- [LHsRecField GhcTc arg]
rbinds
, Name
sel Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr -> Name
idName (Located CoreBndr -> SrcSpanLess (Located CoreBndr)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (Located CoreBndr -> SrcSpanLess (Located CoreBndr))
-> Located CoreBndr -> SrcSpanLess (Located CoreBndr)
forall a b. (a -> b) -> a -> b
$ HsRecField' (FieldOcc GhcTc) arg -> Located CoreBndr
forall arg. HsRecField GhcTc arg -> Located CoreBndr
hsRecFieldId SrcSpanLess (LHsRecField GhcTc arg)
HsRecField' (FieldOcc GhcTc) arg
fld) ]
maxBuildLength :: Int
maxBuildLength :: Int
maxBuildLength = Int
32
dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc]
-> DsM CoreExpr
dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> DsM CoreExpr
dsExplicitList Type
elt_ty Maybe (SyntaxExpr GhcTc)
Nothing [LHsExpr GhcTc]
xs
= do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; [CoreExpr]
xs' <- (LHsExpr GhcTc -> DsM CoreExpr)
-> [LHsExpr GhcTc] -> DsM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP [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
-> ((CoreBndr, Type) -> (CoreBndr, Type) -> DsM CoreExpr)
-> DsM CoreExpr
forall (m :: * -> *).
(MonadFail m, MonadThings m, MonadUnique m) =>
Type
-> ((CoreBndr, Type) -> (CoreBndr, Type) -> m CoreExpr)
-> m CoreExpr
mkBuildExpr Type
elt_ty ([CoreExpr] -> (CoreBndr, Type) -> (CoreBndr, Type) -> DsM CoreExpr
forall (m :: * -> *) (t :: * -> *) b b b.
(Monad m, Foldable t) =>
t (Arg b) -> (CoreBndr, b) -> (CoreBndr, b) -> m (Arg b)
mk_build_list [CoreExpr]
xs') }
where
mk_build_list :: t (Arg b) -> (CoreBndr, b) -> (CoreBndr, b) -> m (Arg b)
mk_build_list t (Arg b)
xs' (CoreBndr
cons, b
_) (CoreBndr
nil, b
_)
= Arg b -> m (Arg b)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Arg b -> Arg b -> Arg b) -> Arg b -> t (Arg b) -> Arg b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Arg b -> Arg b -> Arg b
forall b. Expr b -> Expr b -> Expr b
App (Arg b -> Arg b -> Arg b)
-> (Arg b -> Arg b) -> Arg b -> Arg b -> Arg b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg b -> Arg b -> Arg b
forall b. Expr b -> Expr b -> Expr b
App (CoreBndr -> Arg b
forall b. CoreBndr -> Expr b
Var CoreBndr
cons)) (CoreBndr -> Arg b
forall b. CoreBndr -> Expr b
Var CoreBndr
nil) t (Arg b)
xs')
dsExplicitList Type
elt_ty (Just SyntaxExpr GhcTc
fln) [LHsExpr GhcTc]
xs
= do { CoreExpr
list <- Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] -> DsM CoreExpr
dsExplicitList Type
elt_ty Maybe (SyntaxExpr GhcTc)
forall a. Maybe a
Nothing [LHsExpr GhcTc]
xs
; DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
fln [DynFlags -> Int -> CoreExpr
mkIntExprInt DynFlags
dflags ([LHsExpr GhcTc] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsExpr GhcTc]
xs), CoreExpr
list] }
dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
dsArithSeq :: HsExpr GhcTc -> ArithSeqInfo GhcTc -> DsM CoreExpr
dsArithSeq HsExpr GhcTc
expr (From LHsExpr GhcTc
from)
= CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App (CoreExpr -> CoreExpr -> CoreExpr)
-> DsM CoreExpr -> DsM (CoreExpr -> CoreExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr DsM (CoreExpr -> CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
from
dsArithSeq HsExpr GhcTc
expr (FromTo LHsExpr GhcTc
from LHsExpr GhcTc
to)
= do DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
DynFlags
-> LHsExpr GhcTc
-> Maybe (LHsExpr GhcTc)
-> LHsExpr GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutEmptyEnumerations DynFlags
dflags LHsExpr GhcTc
from Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing LHsExpr GhcTc
to
CoreExpr
expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
CoreExpr
from' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
from
CoreExpr
to' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
to
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
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)
-> DsM [CoreExpr] -> DsM CoreExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LHsExpr GhcTc -> DsM CoreExpr)
-> [LHsExpr GhcTc] -> DsM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP [LHsExpr GhcTc
from, LHsExpr GhcTc
thn]
dsArithSeq HsExpr GhcTc
expr (FromThenTo LHsExpr GhcTc
from LHsExpr GhcTc
thn LHsExpr GhcTc
to)
= do DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
DynFlags
-> LHsExpr GhcTc
-> Maybe (LHsExpr GhcTc)
-> LHsExpr GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) ()
warnAboutEmptyEnumerations DynFlags
dflags LHsExpr GhcTc
from (LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
forall a. a -> Maybe a
Just LHsExpr GhcTc
thn) LHsExpr GhcTc
to
CoreExpr
expr' <- HsExpr GhcTc -> DsM CoreExpr
dsExpr HsExpr GhcTc
expr
CoreExpr
from' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
from
CoreExpr
thn' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
thn
CoreExpr
to' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP LHsExpr GhcTc
to
CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
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 :: [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo [ExprLStmt GhcTc]
stmts
= [ExprLStmt GhcTc] -> DsM CoreExpr
goL [ExprLStmt GhcTc]
stmts
where
goL :: [ExprLStmt GhcTc] -> DsM CoreExpr
goL [] = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsDo"
goL ((ExprLStmt GhcTc -> Located (SrcSpanLess (ExprLStmt GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (ExprLStmt GhcTc)
stmt):[ExprLStmt GhcTc]
lstmts) = SrcSpan -> DsM CoreExpr -> DsM CoreExpr
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (SrcSpan
-> StmtLR GhcTc GhcTc (LHsExpr GhcTc)
-> [ExprLStmt GhcTc]
-> DsM CoreExpr
go SrcSpan
loc SrcSpanLess (ExprLStmt GhcTc)
StmtLR GhcTc GhcTc (LHsExpr GhcTc)
stmt [ExprLStmt GhcTc]
lstmts)
go :: SrcSpan
-> StmtLR GhcTc GhcTc (LHsExpr GhcTc)
-> [ExprLStmt GhcTc]
-> DsM CoreExpr
go SrcSpan
_ (LastStmt XLastStmt GhcTc GhcTc (LHsExpr GhcTc)
_ LHsExpr GhcTc
body Bool
_ SyntaxExpr GhcTc
_) [ExprLStmt GhcTc]
stmts
= ASSERT( null stmts ) dsLExpr body
go SrcSpan
_ (BodyStmt XBodyStmt GhcTc GhcTc (LHsExpr GhcTc)
_ LHsExpr GhcTc
rhs SyntaxExpr GhcTc
then_expr SyntaxExpr GhcTc
_) [ExprLStmt GhcTc]
stmts
= do { CoreExpr
rhs2 <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
rhs
; LHsExpr GhcTc -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDiscardedDoBindings LHsExpr GhcTc
rhs (CoreExpr -> Type
exprType CoreExpr
rhs2)
; CoreExpr
rest <- [ExprLStmt GhcTc] -> DsM CoreExpr
goL [ExprLStmt GhcTc]
stmts
; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
then_expr [CoreExpr
rhs2, CoreExpr
rest] }
go SrcSpan
_ (LetStmt XLetStmt GhcTc GhcTc (LHsExpr GhcTc)
_ LHsLocalBinds GhcTc
binds) [ExprLStmt GhcTc]
stmts
= do { CoreExpr
rest <- [ExprLStmt GhcTc] -> DsM CoreExpr
goL [ExprLStmt GhcTc]
stmts
; LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds LHsLocalBinds GhcTc
binds CoreExpr
rest }
go SrcSpan
_ (BindStmt XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
res1_ty LPat GhcTc
pat LHsExpr GhcTc
rhs SyntaxExpr GhcTc
bind_op SyntaxExpr GhcTc
fail_op) [ExprLStmt GhcTc]
stmts
= do { CoreExpr
body <- [ExprLStmt GhcTc] -> DsM CoreExpr
goL [ExprLStmt GhcTc]
stmts
; CoreExpr
rhs' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
rhs
; CoreBndr
var <- LPat GhcTc -> DsM CoreBndr
selectSimpleMatchVarL LPat GhcTc
pat
; MatchResult
match <- CoreBndr
-> HsMatchContext Name
-> LPat GhcTc
-> Type
-> MatchResult
-> IOEnv (Env DsGblEnv DsLclEnv) MatchResult
matchSinglePatVar CoreBndr
var (HsStmtContext Name -> HsMatchContext Name
forall id. HsStmtContext id -> HsMatchContext id
StmtCtxt HsStmtContext Name
forall id. HsStmtContext id
DoExpr) LPat GhcTc
pat
Type
XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
res1_ty (CoreExpr -> MatchResult
cantFailMatchResult CoreExpr
body)
; CoreExpr
match_code <- LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
handle_failure LPat GhcTc
pat MatchResult
match SyntaxExpr GhcTc
fail_op
; SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
bind_op [CoreExpr
rhs', CoreBndr -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
var CoreExpr
match_code] }
go SrcSpan
_ (ApplicativeStmt XApplicativeStmt GhcTc GhcTc (LHsExpr GhcTc)
body_ty [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args Maybe (SyntaxExpr GhcTc)
mb_join) [ExprLStmt GhcTc]
stmts
= do {
let
([(Located (Pat GhcTc), SyntaxExpr GhcTc)]
pats, [DsM CoreExpr]
rhss) = [((Located (Pat GhcTc), SyntaxExpr GhcTc), DsM CoreExpr)]
-> ([(Located (Pat GhcTc), SyntaxExpr GhcTc)], [DsM CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip (((SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> ((Located (Pat GhcTc), SyntaxExpr GhcTc), DsM CoreExpr))
-> [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
-> [((Located (Pat GhcTc), SyntaxExpr GhcTc), DsM CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (ApplicativeArg GhcTc
-> ((Located (Pat GhcTc), SyntaxExpr GhcTc), DsM CoreExpr)
do_arg (ApplicativeArg GhcTc
-> ((Located (Pat GhcTc), SyntaxExpr GhcTc), DsM CoreExpr))
-> ((SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> ApplicativeArg GhcTc)
-> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-> ((Located (Pat GhcTc), SyntaxExpr GhcTc), DsM CoreExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> ApplicativeArg GhcTc
forall a b. (a, b) -> b
snd) [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args)
do_arg :: ApplicativeArg GhcTc
-> ((Located (Pat GhcTc), SyntaxExpr GhcTc), DsM CoreExpr)
do_arg (ApplicativeArgOne XApplicativeArgOne GhcTc
_ LPat GhcTc
pat LHsExpr GhcTc
expr Bool
_ SyntaxExpr GhcTc
fail_op) =
((Located (Pat GhcTc)
LPat GhcTc
pat, SyntaxExpr GhcTc
fail_op), LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr)
do_arg (ApplicativeArgMany XApplicativeArgMany GhcTc
_ [ExprLStmt GhcTc]
stmts HsExpr GhcTc
ret LPat GhcTc
pat) =
((Located (Pat GhcTc)
LPat GhcTc
pat, SyntaxExpr GhcTc
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr), [ExprLStmt GhcTc] -> DsM CoreExpr
dsDo ([ExprLStmt GhcTc]
stmts [ExprLStmt GhcTc] -> [ExprLStmt GhcTc] -> [ExprLStmt GhcTc]
forall a. [a] -> [a] -> [a]
++ [SrcSpanLess (ExprLStmt GhcTc) -> ExprLStmt GhcTc
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (ExprLStmt GhcTc) -> ExprLStmt GhcTc)
-> SrcSpanLess (ExprLStmt GhcTc) -> ExprLStmt GhcTc
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTc -> StmtLR GhcTc GhcTc (LHsExpr GhcTc)
forall (bodyR :: * -> *) (idR :: Pass) (idL :: Pass).
Located (bodyR (GhcPass idR))
-> StmtLR
(GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkLastStmt (SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
ret)]))
do_arg (XApplicativeArg XXApplicativeArg GhcTc
nec) = NoExtCon -> ((Located (Pat GhcTc), SyntaxExpr GhcTc), DsM CoreExpr)
forall a. NoExtCon -> a
noExtCon XXApplicativeArg GhcTc
NoExtCon
nec
; [CoreExpr]
rhss' <- [DsM CoreExpr] -> DsM [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
$ SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc)
-> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XDo GhcTc
-> HsStmtContext Name -> Located [ExprLStmt GhcTc] -> HsExpr GhcTc
forall p.
XDo p -> HsStmtContext Name -> Located [ExprLStmt p] -> HsExpr p
HsDo XApplicativeStmt GhcTc GhcTc (LHsExpr GhcTc)
XDo GhcTc
body_ty HsStmtContext Name
forall id. HsStmtContext id
DoExpr (SrcSpanLess (Located [ExprLStmt GhcTc])
-> Located [ExprLStmt GhcTc]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [ExprLStmt GhcTc]
SrcSpanLess (Located [ExprLStmt GhcTc])
stmts)
; let match_args :: (Located (Pat GhcTc), SyntaxExpr GhcTc)
-> ([CoreBndr], CoreExpr) -> DsM ([CoreBndr], CoreExpr)
match_args (Located (Pat GhcTc)
pat, SyntaxExpr GhcTc
fail_op) ([CoreBndr]
vs,CoreExpr
body)
= do { CoreBndr
var <- LPat GhcTc -> DsM CoreBndr
selectSimpleMatchVarL Located (Pat GhcTc)
LPat GhcTc
pat
; MatchResult
match <- CoreBndr
-> HsMatchContext Name
-> LPat GhcTc
-> Type
-> MatchResult
-> IOEnv (Env DsGblEnv DsLclEnv) MatchResult
matchSinglePatVar CoreBndr
var (HsStmtContext Name -> HsMatchContext Name
forall id. HsStmtContext id -> HsMatchContext id
StmtCtxt HsStmtContext Name
forall id. HsStmtContext id
DoExpr) Located (Pat GhcTc)
LPat GhcTc
pat
Type
XApplicativeStmt GhcTc GhcTc (LHsExpr GhcTc)
body_ty (CoreExpr -> MatchResult
cantFailMatchResult CoreExpr
body)
; CoreExpr
match_code <- LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
handle_failure Located (Pat GhcTc)
LPat GhcTc
pat MatchResult
match SyntaxExpr GhcTc
fail_op
; ([CoreBndr], CoreExpr) -> DsM ([CoreBndr], CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr
varCoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
vs, CoreExpr
match_code)
}
; ([CoreBndr]
vars, CoreExpr
body) <- ((Located (Pat GhcTc), SyntaxExpr GhcTc)
-> ([CoreBndr], CoreExpr) -> DsM ([CoreBndr], CoreExpr))
-> ([CoreBndr], CoreExpr)
-> [(Located (Pat GhcTc), SyntaxExpr GhcTc)]
-> DsM ([CoreBndr], CoreExpr)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (Located (Pat GhcTc), SyntaxExpr GhcTc)
-> ([CoreBndr], CoreExpr) -> DsM ([CoreBndr], CoreExpr)
match_args ([],CoreExpr
body') [(Located (Pat GhcTc), SyntaxExpr GhcTc)]
pats
; let fun' :: CoreExpr
fun' = [CoreBndr] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
vars CoreExpr
body
; let mk_ap_call :: CoreExpr -> (SyntaxExpr GhcTc, CoreExpr) -> DsM CoreExpr
mk_ap_call CoreExpr
l (SyntaxExpr GhcTc
op,CoreExpr
r) = SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
op [CoreExpr
l,CoreExpr
r]
; CoreExpr
expr <- (CoreExpr -> (SyntaxExpr GhcTc, CoreExpr) -> DsM CoreExpr)
-> CoreExpr -> [(SyntaxExpr GhcTc, CoreExpr)] -> DsM CoreExpr
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CoreExpr -> (SyntaxExpr GhcTc, CoreExpr) -> DsM CoreExpr
mk_ap_call CoreExpr
fun' ([SyntaxExpr GhcTc] -> [CoreExpr] -> [(SyntaxExpr GhcTc, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> SyntaxExpr GhcTc)
-> [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)] -> [SyntaxExpr GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> SyntaxExpr GhcTc
forall a b. (a, b) -> a
fst [(SyntaxExpr GhcTc, ApplicativeArg GhcTc)]
args) [CoreExpr]
rhss')
; case Maybe (SyntaxExpr GhcTc)
mb_join of
Maybe (SyntaxExpr GhcTc)
Nothing -> CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr
Just SyntaxExpr GhcTc
join_op -> SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
join_op [CoreExpr
expr] }
go SrcSpan
loc (RecStmt { recS_stmts :: forall idL idR body. StmtLR idL idR body -> [LStmtLR idL idR body]
recS_stmts = [ExprLStmt GhcTc]
rec_stmts, recS_later_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_later_ids = [IdP GhcTc]
later_ids
, recS_rec_ids :: forall idL idR body. StmtLR idL idR body -> [IdP idR]
recS_rec_ids = [IdP GhcTc]
rec_ids, recS_ret_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_ret_fn = SyntaxExpr GhcTc
return_op
, recS_mfix_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_mfix_fn = SyntaxExpr GhcTc
mfix_op, recS_bind_fn :: forall idL idR body. StmtLR idL idR body -> SyntaxExpr idR
recS_bind_fn = SyntaxExpr GhcTc
bind_op
, recS_ext :: forall idL idR body. StmtLR idL idR body -> XRecStmt idL idR body
recS_ext = RecStmtTc
{ recS_bind_ty = bind_ty
, recS_rec_rets = rec_rets
, recS_ret_ty = body_ty} }) [ExprLStmt GhcTc]
stmts
= [ExprLStmt GhcTc] -> DsM CoreExpr
goL (ExprLStmt GhcTc
new_bind_stmt ExprLStmt GhcTc -> [ExprLStmt GhcTc] -> [ExprLStmt GhcTc]
forall a. a -> [a] -> [a]
: [ExprLStmt GhcTc]
stmts)
where
new_bind_stmt :: ExprLStmt GhcTc
new_bind_stmt = SrcSpan -> SrcSpanLess (ExprLStmt GhcTc) -> ExprLStmt GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (ExprLStmt GhcTc) -> ExprLStmt GhcTc)
-> SrcSpanLess (ExprLStmt GhcTc) -> ExprLStmt GhcTc
forall a b. (a -> b) -> a -> b
$ XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
-> LPat GhcTc
-> LHsExpr GhcTc
-> SyntaxExpr GhcTc
-> SyntaxExpr GhcTc
-> StmtLR GhcTc GhcTc (LHsExpr GhcTc)
forall idL idR body.
XBindStmt idL idR body
-> LPat idL
-> body
-> SyntaxExpr idR
-> SyntaxExpr idR
-> StmtLR idL idR body
BindStmt Type
XBindStmt GhcTc GhcTc (LHsExpr GhcTc)
bind_ty ([LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId [Located (Pat GhcTc)]
[LPat GhcTc]
later_pats)
LHsExpr GhcTc
mfix_app SyntaxExpr GhcTc
bind_op
SyntaxExpr GhcTc
forall (p :: Pass). SyntaxExpr (GhcPass p)
noSyntaxExpr
tup_ids :: [CoreBndr]
tup_ids = [CoreBndr]
[IdP GhcTc]
rec_ids [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ (CoreBndr -> Bool) -> [CoreBndr] -> [CoreBndr]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (CoreBndr -> [CoreBndr] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CoreBndr]
[IdP GhcTc]
rec_ids) [CoreBndr]
[IdP GhcTc]
later_ids
tup_ty :: Type
tup_ty = [Type] -> Type
mkBigCoreTupTy ((CoreBndr -> Type) -> [CoreBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> Type
idType [CoreBndr]
tup_ids)
rec_tup_pats :: [Located (Pat GhcTc)]
rec_tup_pats = (CoreBndr -> Located (Pat GhcTc))
-> [CoreBndr] -> [Located (Pat GhcTc)]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> Located (Pat GhcTc)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat [CoreBndr]
tup_ids
later_pats :: [Located (Pat GhcTc)]
later_pats = [Located (Pat GhcTc)]
rec_tup_pats
rets :: [LHsExpr GhcTc]
rets = (HsExpr GhcTc -> LHsExpr GhcTc)
-> [HsExpr GhcTc] -> [LHsExpr GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map HsExpr GhcTc -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [HsExpr GhcTc]
rec_rets
mfix_app :: LHsExpr GhcTc
mfix_app = SyntaxExpr GhcTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
forall (id :: Pass).
SyntaxExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsSyntaxApps SyntaxExpr GhcTc
mfix_op [LHsExpr GhcTc
mfix_arg]
mfix_arg :: LHsExpr GhcTc
mfix_arg = SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc)
-> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XLam GhcTc -> MatchGroup GhcTc (LHsExpr GhcTc) -> HsExpr GhcTc
forall p. XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
HsLam XLam GhcTc
NoExtField
noExtField
(MG :: forall p body.
XMG p body
-> Located [LMatch p body] -> Origin -> MatchGroup p body
MG { mg_alts :: Located [LMatch GhcTc (LHsExpr GhcTc)]
mg_alts = SrcSpanLess (Located [LMatch GhcTc (LHsExpr GhcTc)])
-> Located [LMatch GhcTc (LHsExpr GhcTc)]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc [HsMatchContext (NameOrRdrName (IdP GhcTc))
-> [LPat GhcTc] -> LHsExpr GhcTc -> LMatch GhcTc (LHsExpr GhcTc)
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch
HsMatchContext (NameOrRdrName (IdP GhcTc))
forall id. HsMatchContext id
LambdaExpr
[Located (Pat GhcTc)
LPat GhcTc
mfix_pat] LHsExpr GhcTc
body]
, mg_ext :: XMG GhcTc (LHsExpr GhcTc)
mg_ext = [Type] -> Type -> MatchGroupTc
MatchGroupTc [Type
tup_ty] Type
body_ty
, mg_origin :: Origin
mg_origin = Origin
Generated })
mfix_pat :: Located (Pat GhcTc)
mfix_pat = SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc))
-> SrcSpanLess (Located (Pat GhcTc)) -> Located (Pat GhcTc)
forall a b. (a -> b) -> a -> b
$ XLazyPat GhcTc -> LPat GhcTc -> Pat GhcTc
forall p. XLazyPat p -> LPat p -> Pat p
LazyPat XLazyPat GhcTc
NoExtField
noExtField (LPat GhcTc -> Pat GhcTc) -> LPat GhcTc -> Pat GhcTc
forall a b. (a -> b) -> a -> b
$ [LPat GhcTc] -> LPat GhcTc
mkBigLHsPatTupId [Located (Pat GhcTc)]
[LPat GhcTc]
rec_tup_pats
body :: LHsExpr GhcTc
body = SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc)
-> SrcSpanLess (LHsExpr GhcTc) -> LHsExpr GhcTc
forall a b. (a -> b) -> a -> b
$ XDo GhcTc
-> HsStmtContext Name -> Located [ExprLStmt GhcTc] -> HsExpr GhcTc
forall p.
XDo p -> HsStmtContext Name -> Located [ExprLStmt p] -> HsExpr p
HsDo Type
XDo GhcTc
body_ty
HsStmtContext Name
forall id. HsStmtContext id
DoExpr (SrcSpanLess (Located [ExprLStmt GhcTc])
-> Located [ExprLStmt GhcTc]
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc ([ExprLStmt GhcTc]
rec_stmts [ExprLStmt GhcTc] -> [ExprLStmt GhcTc] -> [ExprLStmt GhcTc]
forall a. [a] -> [a] -> [a]
++ [ExprLStmt GhcTc
ret_stmt]))
ret_app :: LHsExpr GhcTc
ret_app = SyntaxExpr GhcTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
forall (id :: Pass).
SyntaxExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsSyntaxApps SyntaxExpr GhcTc
return_op [[LHsExpr GhcTc] -> LHsExpr GhcTc
mkBigLHsTupId [LHsExpr GhcTc]
rets]
ret_stmt :: ExprLStmt GhcTc
ret_stmt = SrcSpanLess (ExprLStmt GhcTc) -> ExprLStmt GhcTc
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (ExprLStmt GhcTc) -> ExprLStmt GhcTc)
-> SrcSpanLess (ExprLStmt GhcTc) -> ExprLStmt GhcTc
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcTc -> StmtLR GhcTc GhcTc (LHsExpr GhcTc)
forall (bodyR :: * -> *) (idR :: Pass) (idL :: Pass).
Located (bodyR (GhcPass idR))
-> StmtLR
(GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkLastStmt LHsExpr GhcTc
ret_app
go SrcSpan
_ (ParStmt {}) [ExprLStmt GhcTc]
_ = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsDo ParStmt"
go SrcSpan
_ (TransStmt {}) [ExprLStmt GhcTc]
_ = String -> DsM CoreExpr
forall a. String -> a
panic String
"dsDo TransStmt"
go SrcSpan
_ (XStmtLR XXStmtLR GhcTc GhcTc (LHsExpr GhcTc)
nec) [ExprLStmt GhcTc]
_ = NoExtCon -> DsM CoreExpr
forall a. NoExtCon -> a
noExtCon XXStmtLR GhcTc GhcTc (LHsExpr GhcTc)
NoExtCon
nec
handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
handle_failure LPat GhcTc
pat MatchResult
match SyntaxExpr GhcTc
fail_op
| MatchResult -> Bool
matchCanFail MatchResult
match
= do { DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; CoreExpr
fail_msg <- String -> DsM CoreExpr
forall (m :: * -> *). MonadThings m => String -> m CoreExpr
mkStringExpr (DynFlags -> Located (Pat GhcTc) -> String
forall e. HasSrcSpan e => DynFlags -> e -> String
mk_fail_msg DynFlags
dflags Located (Pat GhcTc)
LPat GhcTc
pat)
; CoreExpr
fail_expr <- SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr SyntaxExpr GhcTc
fail_op [CoreExpr
fail_msg]
; MatchResult -> CoreExpr -> DsM CoreExpr
extractMatchResult MatchResult
match CoreExpr
fail_expr }
| Bool
otherwise
= MatchResult -> CoreExpr -> DsM CoreExpr
extractMatchResult MatchResult
match (String -> CoreExpr
forall a. HasCallStack => String -> a
error String
"It can't fail")
mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
mk_fail_msg :: DynFlags -> e -> String
mk_fail_msg DynFlags
dflags e
pat = String
"Pattern match failure in do expression at " String -> String -> String
forall a. [a] -> [a] -> [a]
++
DynFlags -> SrcSpan -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags (e -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc e
pat)
dsHsVar :: Bool
-> Id -> DsM CoreExpr
dsHsVar :: Bool -> CoreBndr -> DsM CoreExpr
dsHsVar Bool
w CoreBndr
var
| Bool -> Bool
not Bool
w
, let bad_tys :: [Type]
bad_tys = CoreBndr -> Type -> [Type]
badUseOfLevPolyPrimop CoreBndr
var Type
ty
, Bool -> Bool
not ([Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
bad_tys)
= do { CoreBndr -> Type -> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) ()
levPolyPrimopErr CoreBndr
var Type
ty [Type]
bad_tys
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
unitExpr }
| Bool
otherwise
= CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
varToCoreExpr CoreBndr
var)
where
ty :: Type
ty = CoreBndr -> Type
idType CoreBndr
var
dsConLike :: Bool
-> ConLike -> DsM CoreExpr
dsConLike :: Bool -> ConLike -> DsM CoreExpr
dsConLike Bool
w (RealDataCon DataCon
dc) = Bool -> CoreBndr -> DsM CoreExpr
dsHsVar Bool
w (DataCon -> CoreBndr
dataConWrapId DataCon
dc)
dsConLike Bool
_ (PatSynCon PatSyn
ps) = 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
$ case PatSyn -> Maybe (CoreBndr, Bool)
patSynBuilder PatSyn
ps of
Just (CoreBndr
id, Bool
add_void)
| Bool
add_void -> SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp (String -> SDoc
text String
"dsConLike" SDoc -> SDoc -> SDoc
<+> PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
ps) (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
id) (CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
voidPrimId)
| Bool
otherwise -> CoreBndr -> CoreExpr
forall b. CoreBndr -> Expr b
Var CoreBndr
id
Maybe (CoreBndr, Bool)
_ -> String -> SDoc -> 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
$
do { case Type -> Maybe (Type, Type)
tcSplitAppTy_maybe Type
norm_elt_ty of
Just (Type
elt_m_ty, Type
_)
| Type
m_ty Type -> Type -> Bool
`eqType` FamInstEnvs -> Type -> Type
topNormaliseType FamInstEnvs
fam_inst_envs Type
elt_m_ty
-> WarnReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDs (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnWrongDoBind)
(LHsExpr GhcTc -> Type -> SDoc
badMonadBind LHsExpr GhcTc
rhs Type
elt_ty)
Maybe (Type, Type)
_ -> () -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
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
<+> LHsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr GhcTc
rhs)
]
checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()
checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> IOEnv (Env DsGblEnv DsLclEnv) ()
checkForcedEtaExpansion HsExpr GhcTc
expr Type
ty
| Just CoreBndr
var <- case HsExpr GhcTc
expr of
HsVar XVar GhcTc
_ (Located (IdP GhcTc) -> Located (SrcSpanLess (Located CoreBndr))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located CoreBndr)
var) -> CoreBndr -> Maybe CoreBndr
forall a. a -> Maybe a
Just SrcSpanLess (Located CoreBndr)
CoreBndr
var
HsConLikeOut XConLikeOut GhcTc
_ (RealDataCon DataCon
dc) -> CoreBndr -> Maybe CoreBndr
forall a. a -> Maybe a
Just (DataCon -> CoreBndr
dataConWrapId DataCon
dc)
HsExpr GhcTc
_ -> Maybe CoreBndr
forall a. Maybe a
Nothing
, let bad_tys :: [Type]
bad_tys = CoreBndr -> Type -> [Type]
badUseOfLevPolyPrimop CoreBndr
var Type
ty
, Bool -> Bool
not ([Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
bad_tys)
= CoreBndr -> Type -> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) ()
levPolyPrimopErr CoreBndr
var Type
ty [Type]
bad_tys
checkForcedEtaExpansion HsExpr GhcTc
_ Type
_ = () -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
badUseOfLevPolyPrimop :: Id -> Type -> [Type]
badUseOfLevPolyPrimop :: CoreBndr -> Type -> [Type]
badUseOfLevPolyPrimop CoreBndr
id Type
ty
| CoreBndr -> Bool
hasNoBinding CoreBndr
id
= (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filter Type -> Bool
isTypeLevPoly [Type]
arg_tys
| Bool
otherwise
= []
where
([TyCoBinder]
binders, Type
_) = Type -> ([TyCoBinder], Type)
splitPiTys Type
ty
arg_tys :: [Type]
arg_tys = (TyCoBinder -> Maybe Type) -> [TyCoBinder] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TyCoBinder -> Maybe Type
binderRelevantType_maybe [TyCoBinder]
binders
levPolyPrimopErr :: Id -> Type -> [Type] -> DsM ()
levPolyPrimopErr :: CoreBndr -> Type -> [Type] -> IOEnv (Env DsGblEnv DsLclEnv) ()
levPolyPrimopErr CoreBndr
primop Type
ty [Type]
bad_tys
= SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
errDs (SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ())
-> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Cannot use function with levity-polymorphic arguments:")
Int
2 (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
primop SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprWithTYPE Type
ty)
, 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
]