{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
module GHC.Tc.Gen.App
( tcApp
, tcInferSigma
, tcExprPrag ) where
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr )
import GHC.Hs
import GHC.Tc.Gen.Head
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe )
import GHC.Tc.Gen.HsType
import GHC.Tc.Utils.Concrete ( unifyConcrete, idConcreteTvs )
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Tc.Utils.Concrete( hasFixedRuntimeRep_syntactic )
import GHC.Tc.Zonk.TcType
import GHC.Core.ConLike (ConLike(..))
import GHC.Core.DataCon ( dataConConcreteTyVars, isNewDataCon, dataConTyCon )
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr
import GHC.Core.TyCo.Subst ( substTyWithInScope )
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Builtin.Types ( multiplicityTy )
import GHC.Builtin.PrimOps( tagToEnumKey )
import GHC.Builtin.Names
import GHC.Types.Var
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet )
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic( isBoxed )
import Control.Monad
import Data.Function
import Data.Semigroup
import GHC.Prelude
tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType
tcInferSigma :: Bool -> LHsExpr (GhcPass 'Renamed) -> TcM TcType
tcInferSigma Bool
inst (L SrcSpanAnnA
loc HsExpr (GhcPass 'Renamed)
rn_expr)
= HsExpr (GhcPass 'Renamed) -> TcM TcType -> TcM TcType
forall a. HsExpr (GhcPass 'Renamed) -> TcRn a -> TcRn a
addExprCtxt HsExpr (GhcPass 'Renamed)
rn_expr (TcM TcType -> TcM TcType) -> TcM TcType -> TcM TcType
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA -> TcM TcType -> TcM TcType
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM TcType -> TcM TcType) -> TcM TcType -> TcM TcType
forall a b. (a -> b) -> a -> b
$
do { (fun@(rn_fun,fun_ctxt), rn_args) <- HsExpr (GhcPass 'Renamed)
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr (GhcPass 'Renamed)
rn_expr
; do_ql <- wantQuickLook rn_fun
; (tc_fun, fun_sigma) <- tcInferAppHead fun
; (inst_args, app_res_sigma) <- tcInstFun do_ql inst (tc_fun, fun_ctxt) fun_sigma rn_args
; _ <- tcValArgs do_ql inst_args
; return app_res_sigma }
tcApp :: HsExpr GhcRn
-> ExpRhoType
-> TcM (HsExpr GhcTc)
tcApp :: HsExpr (GhcPass 'Renamed) -> ExpRhoType -> TcM (HsExpr GhcTc)
tcApp HsExpr (GhcPass 'Renamed)
rn_expr ExpRhoType
exp_res_ty
= do {
(fun@(rn_fun, fun_ctxt), rn_args) <- HsExpr (GhcPass 'Renamed)
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr (GhcPass 'Renamed)
rn_expr
; traceTc "tcApp {" $
vcat [ text "rn_expr:" <+> ppr rn_expr
, text "rn_fun:" <+> ppr rn_fun
, text "fun_ctxt:" <+> ppr fun_ctxt
, text "rn_args:" <+> ppr rn_args ]
; (tc_fun, fun_sigma) <- tcInferAppHead fun
; let tc_head = (HsExpr GhcTc
tc_fun, AppCtxt
fun_ctxt)
; do_ql <- wantQuickLook rn_fun
; (inst_args, app_res_rho)
<- setQLInstLevel do_ql $
tcInstFun do_ql True tc_head fun_sigma rn_args
; case do_ql of
QLFlag
NoQL -> do { String -> SDoc -> TcRn ()
traceTc String
"tcApp:NoQL" (HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
rn_fun SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
app_res_rho)
; res_wrap <- HsExpr (GhcPass 'Renamed)
-> (HsExpr GhcTc, AppCtxt)
-> [HsExprArg 'TcpInst]
-> TcType
-> ExpRhoType
-> TcM HsWrapper
forall (p :: TcPass).
HsExpr (GhcPass 'Renamed)
-> (HsExpr GhcTc, AppCtxt)
-> [HsExprArg p]
-> TcType
-> ExpRhoType
-> TcM HsWrapper
checkResultTy HsExpr (GhcPass 'Renamed)
rn_expr (HsExpr GhcTc, AppCtxt)
tc_head [HsExprArg 'TcpInst]
inst_args
TcType
app_res_rho ExpRhoType
exp_res_ty
; tc_args <- tcValArgs NoQL inst_args
; finishApp tc_head tc_args app_res_rho res_wrap }
QLFlag
DoQL -> do { String -> SDoc -> TcRn ()
traceTc String
"tcApp:DoQL" (HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
rn_fun SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
app_res_rho)
; TcType -> ExpRhoType -> TcRn ()
quickLookResultType TcType
app_res_rho ExpRhoType
exp_res_ty
; tc_args <- QLFlag -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
tcValArgs QLFlag
DoQL [HsExprArg 'TcpInst]
inst_args
; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
; res_wrap <- checkResultTy rn_expr tc_head inst_args
app_res_rho exp_res_ty
; finishApp tc_head tc_args app_res_rho res_wrap } }
setQLInstLevel :: QLFlag -> TcM a -> TcM a
setQLInstLevel :: forall a. QLFlag -> TcM a -> TcM a
setQLInstLevel QLFlag
DoQL TcM a
thing_inside = TcLevel -> TcM a -> TcM a
forall a. TcLevel -> TcM a -> TcM a
setTcLevel TcLevel
QLInstVar TcM a
thing_inside
setQLInstLevel QLFlag
NoQL TcM a
thing_inside = TcM a
thing_inside
quickLookResultType :: TcRhoType -> ExpRhoType -> TcM ()
quickLookResultType :: TcType -> ExpRhoType -> TcRn ()
quickLookResultType TcType
app_res_rho (Check TcType
exp_rho) = TcType -> TcType -> TcRn ()
qlUnify TcType
app_res_rho TcType
exp_rho
quickLookResultType TcType
_ ExpRhoType
_ = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
finishApp :: (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc]
-> TcRhoType -> HsWrapper
-> TcM (HsExpr GhcTc)
finishApp :: (HsExpr GhcTc, AppCtxt)
-> [HsExprArg 'TcpTc] -> TcType -> HsWrapper -> TcM (HsExpr GhcTc)
finishApp tc_head :: (HsExpr GhcTc, AppCtxt)
tc_head@(HsExpr GhcTc
tc_fun,AppCtxt
_) [HsExprArg 'TcpTc]
tc_args TcType
app_res_rho HsWrapper
res_wrap
= do {
; (HsExpr GhcTc, AppCtxt) -> TcType -> TcRn ()
rejectRepPolyNewtypes (HsExpr GhcTc, AppCtxt)
tc_head TcType
app_res_rho
; res_expr <- if HsExpr GhcTc -> Bool
isTagToEnum HsExpr GhcTc
tc_fun
then (HsExpr GhcTc, AppCtxt)
-> [HsExprArg 'TcpTc] -> TcType -> TcM (HsExpr GhcTc)
tcTagToEnum (HsExpr GhcTc, AppCtxt)
tc_head [HsExprArg 'TcpTc]
tc_args TcType
app_res_rho
else HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (HsExpr GhcTc, AppCtxt)
tc_head [HsExprArg 'TcpTc]
tc_args)
; return (mkHsWrap res_wrap res_expr) }
checkResultTy :: HsExpr GhcRn
-> (HsExpr GhcTc, AppCtxt)
-> [HsExprArg p]
-> TcRhoType
-> ExpRhoType
-> TcM HsWrapper
checkResultTy :: forall (p :: TcPass).
HsExpr (GhcPass 'Renamed)
-> (HsExpr GhcTc, AppCtxt)
-> [HsExprArg p]
-> TcType
-> ExpRhoType
-> TcM HsWrapper
checkResultTy HsExpr (GhcPass 'Renamed)
_ (HsExpr GhcTc, AppCtxt)
_ [HsExprArg p]
_ TcType
app_res_rho (Infer InferResult
inf_res)
= do { co <- TcType -> InferResult -> TcM TcCoercionN
fillInferResult TcType
app_res_rho InferResult
inf_res
; return (mkWpCastN co) }
checkResultTy HsExpr (GhcPass 'Renamed)
rn_expr (HsExpr GhcTc
tc_fun, AppCtxt
fun_ctxt) [HsExprArg p]
inst_args TcType
app_res_rho (Check TcType
res_ty)
= TcM HsWrapper -> TcM HsWrapper
perhaps_add_res_ty_ctxt (TcM HsWrapper -> TcM HsWrapper) -> TcM HsWrapper -> TcM HsWrapper
forall a b. (a -> b) -> a -> b
$
do { ds_flag <- TcM DeepSubsumptionFlag
getDeepSubsumptionFlag
; traceTc "checkResultTy {" $
vcat [ text "tc_fun:" <+> ppr tc_fun
, text "app_res_rho:" <+> ppr app_res_rho
, text "res_ty:" <+> ppr res_ty
, text "ds_flag:" <+> ppr ds_flag ]
; case ds_flag of
DeepSubsumptionFlag
Shallow ->
do { co <- HsExpr (GhcPass 'Renamed) -> TcType -> TcType -> TcM TcCoercionN
unifyExprType HsExpr (GhcPass 'Renamed)
rn_expr TcType
app_res_rho TcType
res_ty
; traceTc "checkResultTy 1 }" (ppr co)
; return (mkWpCastN co) }
DeepSubsumptionFlag
Deep ->
do { wrap <- HsExpr (GhcPass 'Renamed) -> TcType -> TcType -> TcM HsWrapper
tcSubTypeDS HsExpr (GhcPass 'Renamed)
rn_expr TcType
app_res_rho TcType
res_ty
; traceTc "checkResultTy 2 }" (ppr app_res_rho $$ ppr res_ty)
; return wrap } }
where
perhaps_add_res_ty_ctxt :: TcM HsWrapper -> TcM HsWrapper
perhaps_add_res_ty_ctxt TcM HsWrapper
thing_inside
| AppCtxt -> Bool
insideExpansion AppCtxt
fun_ctxt
= AppCtxt -> TcM HsWrapper -> TcM HsWrapper
forall a. AppCtxt -> TcM a -> TcM a
addHeadCtxt AppCtxt
fun_ctxt TcM HsWrapper
thing_inside
| Bool
otherwise
= HsExpr GhcTc
-> [HsExprArg p]
-> TcType
-> ExpRhoType
-> TcM HsWrapper
-> TcM HsWrapper
forall (p :: TcPass) a.
HsExpr GhcTc
-> [HsExprArg p] -> TcType -> ExpRhoType -> TcM a -> TcM a
addFunResCtxt HsExpr GhcTc
tc_fun [HsExprArg p]
inst_args TcType
app_res_rho (TcType -> ExpRhoType
mkCheckExpType TcType
res_ty) (TcM HsWrapper -> TcM HsWrapper) -> TcM HsWrapper -> TcM HsWrapper
forall a b. (a -> b) -> a -> b
$
TcM HsWrapper
thing_inside
tcValArgs :: QLFlag -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
tcValArgs :: QLFlag -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
tcValArgs QLFlag
do_ql [HsExprArg 'TcpInst]
args = (HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc))
-> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (QLFlag
-> HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
tcValArg QLFlag
do_ql) [HsExprArg 'TcpInst]
args
tcValArg :: QLFlag -> HsExprArg 'TcpInst
-> TcM (HsExprArg 'TcpTc)
tcValArg :: QLFlag
-> HsExprArg 'TcpInst
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
tcValArg QLFlag
_ (EPrag AppCtxt
l HsPragE (GhcPass (XPass 'TcpInst))
p) = HsExprArg 'TcpTc
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (AppCtxt -> HsPragE (GhcPass (XPass 'TcpTc)) -> HsExprArg 'TcpTc
forall (p :: TcPass).
AppCtxt -> HsPragE (GhcPass (XPass p)) -> HsExprArg p
EPrag AppCtxt
l (HsPragE (GhcPass 'Renamed) -> HsPragE GhcTc
tcExprPrag HsPragE (GhcPass 'Renamed)
HsPragE (GhcPass (XPass 'TcpInst))
p))
tcValArg QLFlag
_ (ETypeArg AppCtxt
l LHsWcType (GhcPass 'Renamed)
hty XETAType 'TcpInst
ty) = HsExprArg 'TcpTc
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (AppCtxt
-> LHsWcType (GhcPass 'Renamed)
-> XETAType 'TcpTc
-> HsExprArg 'TcpTc
forall (p :: TcPass).
AppCtxt
-> LHsWcType (GhcPass 'Renamed) -> XETAType p -> HsExprArg p
ETypeArg AppCtxt
l LHsWcType (GhcPass 'Renamed)
hty XETAType 'TcpInst
XETAType 'TcpTc
ty)
tcValArg QLFlag
do_ql (EWrap (EHsWrap HsWrapper
w)) = do { QLFlag -> ZonkM () -> TcRn ()
whenQL QLFlag
do_ql (ZonkM () -> TcRn ()) -> ZonkM () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ HsWrapper -> ZonkM ()
qlMonoHsWrapper HsWrapper
w
; HsExprArg 'TcpTc
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EWrap -> HsExprArg 'TcpTc
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap (HsWrapper -> EWrap
EHsWrap HsWrapper
w)) }
tcValArg QLFlag
_ (EWrap EWrap
ew) = HsExprArg 'TcpTc
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EWrap -> HsExprArg 'TcpTc
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap EWrap
ew)
tcValArg QLFlag
do_ql (EValArg { ea_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
ea_ctxt = AppCtxt
ctxt
, ea_arg :: forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg = larg :: LHsExpr (GhcPass (XPass 'TcpInst))
larg@(L SrcSpanAnnA
arg_loc HsExpr (GhcPass 'Renamed)
arg)
, ea_arg_ty :: forall (p :: TcPass). HsExprArg p -> XEVAType p
ea_arg_ty = XEVAType 'TcpInst
sc_arg_ty })
= AppCtxt
-> LHsExpr (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. AppCtxt -> LHsExpr (GhcPass 'Renamed) -> TcM a -> TcM a
addArgCtxt AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
LHsExpr (GhcPass (XPass 'TcpInst))
larg (IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcRn ()
traceTc String
"tcValArg" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ AppCtxt -> SDoc
forall a. Outputable a => a -> SDoc
ppr AppCtxt
ctxt
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg type:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Scaled TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr Scaled TcType
XEVAType 'TcpInst
sc_arg_ty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
arg ]
; Scaled mult exp_arg_ty <- case QLFlag
do_ql of
QLFlag
DoQL -> ZonkM (Scaled TcType)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcType)
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM (Scaled TcType)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcType))
-> ZonkM (Scaled TcType)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcType)
forall a b. (a -> b) -> a -> b
$ Scaled TcType -> ZonkM (Scaled TcType)
zonkScaledTcType Scaled TcType
XEVAType 'TcpInst
sc_arg_ty
QLFlag
NoQL -> Scaled TcType -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Scaled TcType
XEVAType 'TcpInst
sc_arg_ty
; arg' <- tcScalingUsage mult $
tcPolyExpr arg (mkCheckExpType exp_arg_ty)
; return (EValArg { ea_ctxt = ctxt
, ea_arg = L arg_loc arg'
, ea_arg_ty = noExtField }) }
tcValArg QLFlag
_ (EValArgQL { eaql_wanted :: HsExprArg 'TcpInst -> WantedConstraints
eaql_wanted = WantedConstraints
wanted
, eaql_ctxt :: HsExprArg 'TcpInst -> AppCtxt
eaql_ctxt = AppCtxt
ctxt
, eaql_arg_ty :: HsExprArg 'TcpInst -> Scaled TcType
eaql_arg_ty = Scaled TcType
sc_arg_ty
, eaql_larg :: HsExprArg 'TcpInst -> LHsExpr (GhcPass 'Renamed)
eaql_larg = larg :: LHsExpr (GhcPass 'Renamed)
larg@(L SrcSpanAnnA
arg_loc HsExpr (GhcPass 'Renamed)
rn_expr)
, eaql_tc_fun :: HsExprArg 'TcpInst -> (HsExpr GhcTc, AppCtxt)
eaql_tc_fun = (HsExpr GhcTc, AppCtxt)
tc_head
, eaql_args :: HsExprArg 'TcpInst -> [HsExprArg 'TcpInst]
eaql_args = [HsExprArg 'TcpInst]
inst_args
, eaql_encl :: HsExprArg 'TcpInst -> Bool
eaql_encl = Bool
arg_influences_enclosing_call
, eaql_res_rho :: HsExprArg 'TcpInst -> TcType
eaql_res_rho = TcType
app_res_rho })
= AppCtxt
-> LHsExpr (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a. AppCtxt -> LHsExpr (GhcPass 'Renamed) -> TcM a -> TcM a
addArgCtxt AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
larg (IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc))
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
-> IOEnv (Env TcGblEnv TcLclEnv) (HsExprArg 'TcpTc)
forall a b. (a -> b) -> a -> b
$
do {
Scaled mult exp_arg_ty <- ZonkM (Scaled TcType)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcType)
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM (Scaled TcType)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcType))
-> ZonkM (Scaled TcType)
-> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcType)
forall a b. (a -> b) -> a -> b
$ Scaled TcType -> ZonkM (Scaled TcType)
zonkScaledTcType Scaled TcType
sc_arg_ty
; traceTc "tcEValArgQL {" (vcat [ text "app_res_rho:" <+> ppr app_res_rho
, text "exp_arg_ty:" <+> ppr exp_arg_ty
, text "args:" <+> ppr inst_args ])
; ds_flag <- getDeepSubsumptionFlag
; (wrap, arg')
<- tcScalingUsage mult $
tcSkolemise ds_flag GenSigCtxt exp_arg_ty $ \ TcType
exp_arg_rho ->
do {
WantedConstraints -> TcRn ()
emitConstraints WantedConstraints
wanted
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
arg_influences_enclosing_call (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
TcType -> TcType -> TcRn ()
qlUnify TcType
app_res_rho TcType
exp_arg_rho
; tc_args <- QLFlag -> [HsExprArg 'TcpInst] -> TcM [HsExprArg 'TcpTc]
tcValArgs QLFlag
DoQL [HsExprArg 'TcpInst]
inst_args
; app_res_rho <- liftZonkM $ zonkTcType app_res_rho
; res_wrap <- checkResultTy rn_expr tc_head inst_args
app_res_rho (mkCheckExpType exp_arg_rho)
; finishApp tc_head tc_args app_res_rho res_wrap }
; traceTc "tcEValArgQL }" $
vcat [ text "app_res_rho:" <+> ppr app_res_rho ]
; return (EValArg { ea_ctxt = ctxt
, ea_arg = L arg_loc (mkHsWrap wrap arg')
, ea_arg_ty = noExtField }) }
wantQuickLook :: HsExpr GhcRn -> TcM QLFlag
wantQuickLook :: HsExpr (GhcPass 'Renamed) -> TcM QLFlag
wantQuickLook (HsVar XVar (GhcPass 'Renamed)
_ (L SrcSpanAnnN
_ Name
f))
| Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
f Unique -> [Unique] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unique]
quickLookKeys = QLFlag -> TcM QLFlag
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return QLFlag
DoQL
wantQuickLook HsExpr (GhcPass 'Renamed)
_ = do { impred <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ImpredicativeTypes
; if impred then return DoQL else return NoQL }
quickLookKeys :: [Unique]
quickLookKeys :: [Unique]
quickLookKeys = [Unique
dollarIdKey, Unique
leftSectionKey, Unique
rightSectionKey]
tcInstFun :: QLFlag
-> Bool
-> (HsExpr GhcTc, AppCtxt)
-> TcSigmaType -> [HsExprArg 'TcpRn]
-> TcM ( [HsExprArg 'TcpInst]
, TcSigmaType )
tcInstFun :: QLFlag
-> Bool
-> (HsExpr GhcTc, AppCtxt)
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM ([HsExprArg 'TcpInst], TcType)
tcInstFun QLFlag
do_ql Bool
inst_final (HsExpr GhcTc
tc_fun, AppCtxt
fun_ctxt) TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args
= do { String -> SDoc -> TcRn ()
traceTc String
"tcInstFun" ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tc_fun" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> HsExpr GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcTc
tc_fun
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fun_sigma" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
fun_sigma
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fun_ctxt" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> AppCtxt -> SDoc
forall a. Outputable a => a -> SDoc
ppr AppCtxt
fun_ctxt
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"args:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [HsExprArg 'TcpRn] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsExprArg 'TcpRn]
rn_args
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"do_ql" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> QLFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr QLFlag
do_ql ])
; Int
-> [HsExprArg 'TcpInst]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM ([HsExprArg 'TcpInst], TcType)
go Int
1 [] TcType
fun_sigma [HsExprArg 'TcpRn]
rn_args }
where
fun_orig :: CtOrigin
fun_orig = case AppCtxt
fun_ctxt of
VAExpansion (OrigStmt{}) SrcSpan
_ SrcSpan
_ -> CtOrigin
DoOrigin
VAExpansion (OrigPat LPat (GhcPass 'Renamed)
pat) SrcSpan
_ SrcSpan
_ -> LPat (GhcPass 'Renamed) -> CtOrigin
DoPatOrigin LPat (GhcPass 'Renamed)
pat
VAExpansion (OrigExpr HsExpr (GhcPass 'Renamed)
e) SrcSpan
_ SrcSpan
_ -> HsExpr (GhcPass 'Renamed) -> CtOrigin
exprCtOrigin HsExpr (GhcPass 'Renamed)
e
VACall HsExpr (GhcPass 'Renamed)
e Int
_ SrcSpan
_ -> HsExpr (GhcPass 'Renamed) -> CtOrigin
exprCtOrigin HsExpr (GhcPass 'Renamed)
e
fun_conc_tvs :: ConcreteTyVars
fun_conc_tvs
| HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Id
fun_id) <- HsExpr GhcTc
tc_fun
= Id -> ConcreteTyVars
idConcreteTvs Id
fun_id
| XExpr (ConLikeTc (RealDataCon DataCon
dc) [Id]
_ [Scaled TcType]
_) <- HsExpr GhcTc
tc_fun
= DataCon -> ConcreteTyVars
dataConConcreteTyVars DataCon
dc
| Bool
otherwise
= ConcreteTyVars
noConcreteTyVars
n_val_args :: Int
n_val_args = (HsExprArg 'TcpRn -> Bool) -> [HsExprArg 'TcpRn] -> Int
forall a. (a -> Bool) -> [a] -> Int
count HsExprArg 'TcpRn -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isHsValArg [HsExprArg 'TcpRn]
rn_args
fun_is_out_of_scope :: Bool
fun_is_out_of_scope
= case HsExpr GhcTc
tc_fun of
HsUnboundVar {} -> Bool
True
HsExpr GhcTc
_ -> Bool
False
inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool
inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool
inst_fun [] | Bool
inst_final = ForAllTyFlag -> Bool
isInvisibleForAllTyFlag
| Bool
otherwise = Bool -> ForAllTyFlag -> Bool
forall a b. a -> b -> a
const Bool
False
inst_fun (EValArg {} : [HsExprArg 'TcpRn]
_) = ForAllTyFlag -> Bool
isInvisibleForAllTyFlag
inst_fun [HsExprArg 'TcpRn]
_ = ForAllTyFlag -> Bool
isInferredForAllTyFlag
go, go1 :: Int
-> [HsExprArg 'TcpInst]
-> TcSigmaType -> [HsExprArg 'TcpRn]
-> TcM ([HsExprArg 'TcpInst], TcSigmaType)
go :: Int
-> [HsExprArg 'TcpInst]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM ([HsExprArg 'TcpInst], TcType)
go Int
pos [HsExprArg 'TcpInst]
acc TcType
fun_ty [HsExprArg 'TcpRn]
args
| Just Id
kappa <- TcType -> Maybe Id
getTyVar_maybe TcType
fun_ty
, Id -> Bool
isQLInstTyVar Id
kappa
= do { cts <- Id -> IOEnv (Env TcGblEnv TcLclEnv) MetaDetails
forall (m :: * -> *). MonadIO m => Id -> m MetaDetails
readMetaTyVar Id
kappa
; case cts of
Indirect TcType
fun_ty' -> Int
-> [HsExprArg 'TcpInst]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM ([HsExprArg 'TcpInst], TcType)
go Int
pos [HsExprArg 'TcpInst]
acc TcType
fun_ty' [HsExprArg 'TcpRn]
args
MetaDetails
Flexi -> Int
-> [HsExprArg 'TcpInst]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM ([HsExprArg 'TcpInst], TcType)
go1 Int
pos [HsExprArg 'TcpInst]
acc TcType
fun_ty [HsExprArg 'TcpRn]
args }
| Bool
otherwise
= Int
-> [HsExprArg 'TcpInst]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM ([HsExprArg 'TcpInst], TcType)
go1 Int
pos [HsExprArg 'TcpInst]
acc TcType
fun_ty [HsExprArg 'TcpRn]
args
go1 :: Int
-> [HsExprArg 'TcpInst]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM ([HsExprArg 'TcpInst], TcType)
go1 Int
pos [HsExprArg 'TcpInst]
acc TcType
fun_ty (HsExprArg 'TcpRn
arg : [HsExprArg 'TcpRn]
rest_args)
| Bool
fun_is_out_of_scope, HsExprArg 'TcpRn -> Bool
looks_like_type_arg HsExprArg 'TcpRn
arg
= Int
-> [HsExprArg 'TcpInst]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM ([HsExprArg 'TcpInst], TcType)
go Int
pos [HsExprArg 'TcpInst]
acc TcType
fun_ty [HsExprArg 'TcpRn]
rest_args
go1 Int
pos [HsExprArg 'TcpInst]
acc TcType
fun_ty [HsExprArg 'TcpRn]
args
| ([Id]
tvs, TcType
body1) <- (ForAllTyFlag -> Bool) -> TcType -> ([Id], TcType)
tcSplitSomeForAllTyVars ([HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool
inst_fun [HsExprArg 'TcpRn]
args) TcType
fun_ty
, (ThetaType
theta, TcType
body2) <- if [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool
inst_fun [HsExprArg 'TcpRn]
args ForAllTyFlag
Inferred
then TcType -> (ThetaType, TcType)
tcSplitPhiTy TcType
body1
else ([], TcType
body1)
, let no_tvs :: Bool
no_tvs = [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
tvs
no_theta :: Bool
no_theta = ThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ThetaType
theta
, Bool -> Bool
not (Bool
no_tvs Bool -> Bool -> Bool
&& Bool
no_theta)
= do { (_inst_tvs, wrap, fun_rho) <-
AppCtxt
-> TcM ([Id], HsWrapper, TcType) -> TcM ([Id], HsWrapper, TcType)
forall a. AppCtxt -> TcM a -> TcM a
addHeadCtxt AppCtxt
fun_ctxt (TcM ([Id], HsWrapper, TcType) -> TcM ([Id], HsWrapper, TcType))
-> TcM ([Id], HsWrapper, TcType) -> TcM ([Id], HsWrapper, TcType)
forall a b. (a -> b) -> a -> b
$
CtOrigin
-> ConcreteTyVars
-> [Id]
-> ThetaType
-> TcType
-> TcM ([Id], HsWrapper, TcType)
instantiateSigma CtOrigin
fun_orig ConcreteTyVars
fun_conc_tvs [Id]
tvs ThetaType
theta TcType
body2
; go pos (addArgWrap wrap acc) fun_rho args }
go1 Int
_pos [HsExprArg 'TcpInst]
acc TcType
fun_ty []
= do { String -> SDoc -> TcRn ()
traceTc String
"tcInstFun:ret" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
fun_ty)
; ([HsExprArg 'TcpInst], TcType)
-> TcM ([HsExprArg 'TcpInst], TcType)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. [a] -> [a]
reverse [HsExprArg 'TcpInst]
acc, TcType
fun_ty) }
go1 Int
pos [HsExprArg 'TcpInst]
acc TcType
fun_ty ((EValArg { ea_arg :: forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg = LHsExpr (GhcPass (XPass 'TcpRn))
arg }) : [HsExprArg 'TcpRn]
rest_args)
| Just (TyVarBinder
tvb, TcType
body) <- TcType -> Maybe (TyVarBinder, TcType)
tcSplitForAllTyVarBinder_maybe TcType
fun_ty
= Bool
-> SDoc
-> TcM ([HsExprArg 'TcpInst], TcType)
-> TcM ([HsExprArg 'TcpInst], TcType)
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (TyVarBinder -> ForAllTyFlag
forall tv argf. VarBndr tv argf -> argf
binderFlag TyVarBinder
tvb ForAllTyFlag -> ForAllTyFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ForAllTyFlag
Required) (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
fun_ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsExpr (GhcPass (XPass 'TcpRn))
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
arg) (TcM ([HsExprArg 'TcpInst], TcType)
-> TcM ([HsExprArg 'TcpInst], TcType))
-> TcM ([HsExprArg 'TcpInst], TcType)
-> TcM ([HsExprArg 'TcpInst], TcType)
forall a b. (a -> b) -> a -> b
$
do { (ty_arg, inst_body) <- ConcreteTyVars
-> (TyVarBinder, TcType)
-> LHsExpr (GhcPass 'Renamed)
-> TcM (TcType, TcType)
tcVDQ ConcreteTyVars
fun_conc_tvs (TyVarBinder
tvb, TcType
body) LHsExpr (GhcPass 'Renamed)
LHsExpr (GhcPass (XPass 'TcpRn))
arg
; let wrap = ThetaType -> HsWrapper
mkWpTyApps [TcType
ty_arg]
; go (pos+1) (addArgWrap wrap acc) inst_body rest_args }
go1 Int
pos [HsExprArg 'TcpInst]
acc TcType
fun_ty (EWrap EWrap
w : [HsExprArg 'TcpRn]
args)
= Int
-> [HsExprArg 'TcpInst]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM ([HsExprArg 'TcpInst], TcType)
go1 Int
pos (EWrap -> HsExprArg 'TcpInst
forall (p :: TcPass). EWrap -> HsExprArg p
EWrap EWrap
w HsExprArg 'TcpInst -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpInst]
acc) TcType
fun_ty [HsExprArg 'TcpRn]
args
go1 Int
pos [HsExprArg 'TcpInst]
acc TcType
fun_ty (EPrag AppCtxt
sp HsPragE (GhcPass (XPass 'TcpRn))
prag : [HsExprArg 'TcpRn]
args)
= Int
-> [HsExprArg 'TcpInst]
-> TcType
-> [HsExprArg 'TcpRn]
-> TcM ([HsExprArg 'TcpInst], TcType)
go1 Int
pos (AppCtxt -> HsPragE (GhcPass (XPass 'TcpInst)) -> HsExprArg 'TcpInst
forall (p :: TcPass).
AppCtxt -> HsPragE (GhcPass (XPass p)) -> HsExprArg p
EPrag AppCtxt
sp HsPragE (GhcPass (XPass 'TcpRn))
HsPragE (GhcPass (XPass 'TcpInst))
prag HsExprArg 'TcpInst -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. a -> [a] -> [a]
: [HsExprArg 'TcpInst]
acc) TcType
fun_ty [HsExprArg 'TcpRn]
args
go1 Int
pos [HsExprArg 'TcpInst]
acc TcType
fun_ty ( ETypeArg { ea_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
ea_ctxt = AppCtxt
ctxt, ea_hs_ty :: forall (p :: TcPass). HsExprArg p -> LHsWcType (GhcPass 'Renamed)
ea_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty }
: [HsExprArg 'TcpRn]
rest_args )
= do { (ty_arg, inst_ty) <- ConcreteTyVars
-> TcType -> LHsWcType (GhcPass 'Renamed) -> TcM (TcType, TcType)
tcVTA ConcreteTyVars
fun_conc_tvs TcType
fun_ty LHsWcType (GhcPass 'Renamed)
hs_ty
; let arg' = ETypeArg { ea_ctxt :: AppCtxt
ea_ctxt = AppCtxt
ctxt, ea_hs_ty :: LHsWcType (GhcPass 'Renamed)
ea_hs_ty = LHsWcType (GhcPass 'Renamed)
hs_ty, ea_ty_arg :: XETAType 'TcpInst
ea_ty_arg = TcType
XETAType 'TcpInst
ty_arg }
; go pos (arg' : acc) inst_ty rest_args }
go1 Int
pos [HsExprArg 'TcpInst]
acc TcType
fun_ty args :: [HsExprArg 'TcpRn]
args@(EValArg {} : [HsExprArg 'TcpRn]
_)
| Just Id
kappa <- TcType -> Maybe Id
getTyVar_maybe TcType
fun_ty
, Id -> Bool
isQLInstTyVar Id
kappa
=
do { arg_tys <- (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> Int -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcType))
-> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))]
-> [Int]
-> IOEnv (Env TcGblEnv TcLclEnv) [Scaled TcType]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM LHsExpr (GhcPass 'Renamed)
-> Int -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcType)
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> Int -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcType)
new_arg_ty ([HsExprArg 'TcpRn] -> [LHsExpr (GhcPass 'Renamed)]
leadingValArgs [HsExprArg 'TcpRn]
args) [Int
pos..]
; res_ty <- newOpenFlexiTyVarTy
; let fun_ty' = [Scaled TcType] -> TcType -> TcType
HasDebugCallStack => [Scaled TcType] -> TcType -> TcType
mkScaledFunTys [Scaled TcType]
arg_tys TcType
res_ty
; kind_co <- unifyKind Nothing liftedTypeKind (tyVarKind kappa)
; liftZonkM (writeMetaTyVar kappa (mkCastTy fun_ty' kind_co))
; let co_wrap = TcCoercionN -> HsWrapper
mkWpCastN (Role -> TcType -> TcCoercionN -> TcCoercionN
mkGReflLeftCo Role
Nominal TcType
fun_ty' TcCoercionN
kind_co)
acc' = HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall (p :: TcPass). HsWrapper -> [HsExprArg p] -> [HsExprArg p]
addArgWrap HsWrapper
co_wrap [HsExprArg 'TcpInst]
acc
; go pos acc' fun_ty' args }
go1 Int
pos [HsExprArg 'TcpInst]
acc TcType
fun_ty
(EValArg { ea_arg :: forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg = LHsExpr (GhcPass (XPass 'TcpRn))
arg, ea_ctxt :: forall (p :: TcPass). HsExprArg p -> AppCtxt
ea_ctxt = AppCtxt
ctxt } : [HsExprArg 'TcpRn]
rest_args)
= do { let herald :: ExpectedFunTyOrigin
herald = case AppCtxt
fun_ctxt of
VAExpansion (OrigStmt{}) SrcSpan
_ SrcSpan
_ -> CtOrigin -> HsExpr GhcTc -> ExpectedFunTyOrigin
forall (p :: Pass).
OutputableBndrId p =>
CtOrigin -> HsExpr (GhcPass p) -> ExpectedFunTyOrigin
ExpectedFunTySyntaxOp CtOrigin
DoOrigin HsExpr GhcTc
tc_fun
AppCtxt
_ -> TypedThing -> HsExpr (GhcPass 'Renamed) -> ExpectedFunTyOrigin
forall (p :: Pass).
Outputable (HsExpr (GhcPass p)) =>
TypedThing -> HsExpr (GhcPass p) -> ExpectedFunTyOrigin
ExpectedFunTyArg (HsExpr GhcTc -> TypedThing
HsExprTcThing HsExpr GhcTc
tc_fun) (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> HsExpr (GhcPass 'Renamed)
forall l e. GenLocated l e -> e
unLoc LHsExpr (GhcPass (XPass 'TcpRn))
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
arg)
; (wrap, arg_ty, res_ty) <-
ExpectedFunTyOrigin
-> Maybe TypedThing
-> (Int, TcType)
-> TcType
-> TcM (HsWrapper, Scaled TcType, TcType)
matchActualFunTy ExpectedFunTyOrigin
herald
(TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just (TypedThing -> Maybe TypedThing) -> TypedThing -> Maybe TypedThing
forall a b. (a -> b) -> a -> b
$ HsExpr GhcTc -> TypedThing
HsExprTcThing HsExpr GhcTc
tc_fun)
(Int
n_val_args, TcType
fun_sigma) TcType
fun_ty
; arg' <- quickLookArg do_ql ctxt arg arg_ty
; let acc' = HsExprArg 'TcpInst
arg' HsExprArg 'TcpInst -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall a. a -> [a] -> [a]
: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
forall (p :: TcPass). HsWrapper -> [HsExprArg p] -> [HsExprArg p]
addArgWrap HsWrapper
wrap [HsExprArg 'TcpInst]
acc
; go (pos+1) acc' res_ty rest_args }
new_arg_ty :: LHsExpr GhcRn -> Int -> TcM (Scaled TcType)
new_arg_ty :: LHsExpr (GhcPass 'Renamed)
-> Int -> IOEnv (Env TcGblEnv TcLclEnv) (Scaled TcType)
new_arg_ty (L SrcSpanAnnA
_ HsExpr (GhcPass 'Renamed)
arg) Int
i
= do { arg_nu <- FixedRuntimeRepContext -> TcM TcType
newOpenFlexiFRRTyVarTy (FixedRuntimeRepContext -> TcM TcType)
-> FixedRuntimeRepContext -> TcM TcType
forall a b. (a -> b) -> a -> b
$
ExpectedFunTyOrigin -> Int -> FixedRuntimeRepContext
FRRExpectedFunTy (TypedThing -> HsExpr (GhcPass 'Renamed) -> ExpectedFunTyOrigin
forall (p :: Pass).
Outputable (HsExpr (GhcPass p)) =>
TypedThing -> HsExpr (GhcPass p) -> ExpectedFunTyOrigin
ExpectedFunTyArg (HsExpr GhcTc -> TypedThing
HsExprTcThing HsExpr GhcTc
tc_fun) HsExpr (GhcPass 'Renamed)
arg) Int
i
; mult_ty <- newFlexiTyVarTy multiplicityTy
; return (mkScaled mult_ty arg_nu) }
looks_like_type_arg :: HsExprArg 'TcpRn -> Bool
looks_like_type_arg :: HsExprArg 'TcpRn -> Bool
looks_like_type_arg ETypeArg{} =
Bool
True
looks_like_type_arg EValArg{ ea_arg :: forall (p :: TcPass). HsExprArg p -> LHsExpr (GhcPass (XPass p))
ea_arg = L SrcSpanAnnA
_ HsExpr (GhcPass 'Renamed)
e } =
case HsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)
forall (p :: Pass). HsExpr (GhcPass p) -> HsExpr (GhcPass p)
stripParensHsExpr HsExpr (GhcPass 'Renamed)
e of
HsEmbTy XEmbTy (GhcPass 'Renamed)
_ LHsWcType (NoGhcTc (GhcPass 'Renamed))
_ -> Bool
True
HsExpr (GhcPass 'Renamed)
_ -> Bool
False
looks_like_type_arg HsExprArg 'TcpRn
_ = Bool
False
addArgCtxt :: AppCtxt -> LHsExpr GhcRn
-> TcM a -> TcM a
addArgCtxt :: forall a. AppCtxt -> LHsExpr (GhcPass 'Renamed) -> TcM a -> TcM a
addArgCtxt AppCtxt
ctxt (L SrcSpanAnnA
arg_loc HsExpr (GhcPass 'Renamed)
arg) TcM a
thing_inside
= do { in_generated_code <- TcRnIf TcGblEnv TcLclEnv Bool
inGeneratedCode
; case ctxt of
VACall HsExpr (GhcPass 'Renamed)
fun Int
arg_no SrcSpan
_ | Bool -> Bool
not Bool
in_generated_code
-> do SrcSpanAnnA -> TcM a -> TcM a
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
arg_loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (HsExpr (GhcPass 'Renamed)
-> HsExpr (GhcPass 'Renamed) -> Int -> SDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Int -> SDoc
funAppCtxt HsExpr (GhcPass 'Renamed)
fun HsExpr (GhcPass 'Renamed)
arg Int
arg_no) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
VAExpansion (OrigStmt (L SrcSpanAnnA
_ stmt :: StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
stmt@(BindStmt {}))) SrcSpan
_ SrcSpan
loc
| SrcSpan -> Bool
isGeneratedSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
arg_loc)
-> SrcSpan -> TcM a -> TcM a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
ExprStmt (GhcPass 'Renamed) -> TcM a -> TcM a
forall a. ExprStmt (GhcPass 'Renamed) -> TcRn a -> TcRn a
addStmtCtxt ExprStmt (GhcPass 'Renamed)
StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
stmt (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
| Bool
otherwise
-> SrcSpanAnnA -> TcM a -> TcM a
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
arg_loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
ExprStmt (GhcPass 'Renamed) -> TcM a -> TcM a
forall a. ExprStmt (GhcPass 'Renamed) -> TcRn a -> TcRn a
addStmtCtxt ExprStmt (GhcPass 'Renamed)
StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
stmt (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
VAExpansion (OrigStmt (L SrcSpanAnnA
loc StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
stmt)) SrcSpan
_ SrcSpan
_
-> SrcSpanAnnA -> TcM a -> TcM a
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
ExprStmt (GhcPass 'Renamed) -> TcM a -> TcM a
forall a. ExprStmt (GhcPass 'Renamed) -> TcRn a -> TcRn a
addStmtCtxt ExprStmt (GhcPass 'Renamed)
StmtLR
(GhcPass 'Renamed)
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
stmt (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
AppCtxt
_ -> SrcSpanAnnA -> TcM a -> TcM a
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
arg_loc (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
HsExpr (GhcPass 'Renamed) -> TcM a -> TcM a
forall a. HsExpr (GhcPass 'Renamed) -> TcRn a -> TcRn a
addExprCtxt HsExpr (GhcPass 'Renamed)
arg (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside }
tcVTA :: ConcreteTyVars
-> TcType
-> LHsWcType GhcRn
-> TcM (TcType, TcType)
tcVTA :: ConcreteTyVars
-> TcType -> LHsWcType (GhcPass 'Renamed) -> TcM (TcType, TcType)
tcVTA ConcreteTyVars
conc_tvs TcType
fun_ty LHsWcType (GhcPass 'Renamed)
hs_ty
| Just (TyVarBinder
tvb, TcType
inner_ty) <- TcType -> Maybe (TyVarBinder, TcType)
tcSplitForAllTyVarBinder_maybe TcType
fun_ty
, TyVarBinder -> ForAllTyFlag
forall tv argf. VarBndr tv argf -> argf
binderFlag TyVarBinder
tvb ForAllTyFlag -> ForAllTyFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ForAllTyFlag
Specified
= do { ConcreteTyVars
-> (TyVarBinder, TcType)
-> LHsWcType (GhcPass 'Renamed)
-> TcM (TcType, TcType)
tc_inst_forall_arg ConcreteTyVars
conc_tvs (TyVarBinder
tvb, TcType
inner_ty) LHsWcType (GhcPass 'Renamed)
hs_ty }
| Bool
otherwise
= do { (_, fun_ty) <- ZonkM (TidyEnv, TcType) -> TcM (TidyEnv, TcType)
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM (TidyEnv, TcType) -> TcM (TidyEnv, TcType))
-> ZonkM (TidyEnv, TcType) -> TcM (TidyEnv, TcType)
forall a b. (a -> b) -> a -> b
$ TidyEnv -> TcType -> ZonkM (TidyEnv, TcType)
zonkTidyTcType TidyEnv
emptyTidyEnv TcType
fun_ty
; failWith $ TcRnInvalidTypeApplication fun_ty hs_ty }
tcVDQ :: ConcreteTyVars
-> (ForAllTyBinder, TcType)
-> LHsExpr GhcRn
-> TcM (TcType, TcType)
tcVDQ :: ConcreteTyVars
-> (TyVarBinder, TcType)
-> LHsExpr (GhcPass 'Renamed)
-> TcM (TcType, TcType)
tcVDQ ConcreteTyVars
conc_tvs (TyVarBinder
tvb, TcType
inner_ty) LHsExpr (GhcPass 'Renamed)
arg
= do { hs_wc_ty <- LHsExpr (GhcPass 'Renamed) -> TcM (LHsWcType (GhcPass 'Renamed))
expr_to_type LHsExpr (GhcPass 'Renamed)
arg
; tc_inst_forall_arg conc_tvs (tvb, inner_ty) hs_wc_ty }
expr_to_type :: LHsExpr GhcRn -> TcM (LHsWcType GhcRn)
expr_to_type :: LHsExpr (GhcPass 'Renamed) -> TcM (LHsWcType (GhcPass 'Renamed))
expr_to_type LHsExpr (GhcPass 'Renamed)
earg =
case LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)
forall (p :: Pass). LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
stripParensLHsExpr LHsExpr (GhcPass 'Renamed)
earg of
L SrcSpanAnnA
_ (HsEmbTy XEmbTy (GhcPass 'Renamed)
_ LHsWcType (NoGhcTc (GhcPass 'Renamed))
hs_ty) ->
HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsWcType (NoGhcTc (GhcPass 'Renamed))
HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
hs_ty
LHsExpr (GhcPass 'Renamed)
e ->
XHsWC
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
-> HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC [] (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
-> HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
go LHsExpr (GhcPass 'Renamed)
e
where
go :: LHsExpr GhcRn -> TcM (LHsType GhcRn)
go :: LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
go (L SrcSpanAnnA
_ (HsEmbTy XEmbTy (GhcPass 'Renamed)
_ LHsWcType (NoGhcTc (GhcPass 'Renamed))
t)) =
HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
forall t. HsWildCardBndrs (GhcPass 'Renamed) t -> TcM t
unwrap_wc LHsWcType (NoGhcTc (GhcPass 'Renamed))
HsWildCardBndrs
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
t
go (L SrcSpanAnnA
l (HsFunArr XFunArr (GhcPass 'Renamed)
_ HsArrowOf (LHsExpr (GhcPass 'Renamed)) (GhcPass 'Renamed)
mult LHsExpr (GhcPass 'Renamed)
arg LHsExpr (GhcPass 'Renamed)
res)) =
do { arg' <- LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
go LHsExpr (GhcPass 'Renamed)
arg
; mult' <- go_arrow mult
; res' <- go res
; return (L l (HsFunTy noExtField mult' arg' res'))}
where
go_arrow :: HsArrowOf (LHsExpr GhcRn) GhcRn -> TcM (HsArrow GhcRn)
go_arrow :: HsArrowOf (LHsExpr (GhcPass 'Renamed)) (GhcPass 'Renamed)
-> TcM (HsArrow (GhcPass 'Renamed))
go_arrow (HsUnrestrictedArrow{}) = HsArrowOf
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsArrowOf
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XUnrestrictedArrow
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed)
-> HsArrowOf
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed)
forall mult pass.
XUnrestrictedArrow mult pass -> HsArrowOf mult pass
HsUnrestrictedArrow NoExtField
XUnrestrictedArrow
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed)
noExtField)
go_arrow (HsLinearArrow{}) = HsArrowOf
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsArrowOf
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XLinearArrow
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed)
-> HsArrowOf
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed)
forall mult pass. XLinearArrow mult pass -> HsArrowOf mult pass
HsLinearArrow NoExtField
XLinearArrow
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed)
noExtField)
go_arrow (HsExplicitMult XExplicitMult (LHsExpr (GhcPass 'Renamed)) (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
exp) = XExplicitMult
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
-> HsArrowOf
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed)
forall mult pass.
XExplicitMult mult pass -> mult -> HsArrowOf mult pass
HsExplicitMult NoExtField
XExplicitMult
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed)
noExtField (GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
-> HsArrowOf
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(HsArrowOf
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
(GhcPass 'Renamed))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
go LHsExpr (GhcPass 'Renamed)
exp
go (L SrcSpanAnnA
l (HsForAll XForAll (GhcPass 'Renamed)
_ HsForAllTelescope (GhcPass 'Renamed)
tele LHsExpr (GhcPass 'Renamed)
expr)) =
do { ty <- LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
go LHsExpr (GhcPass 'Renamed)
expr
; return (L l (HsForAllTy noExtField tele ty))}
go (L SrcSpanAnnA
l (HsQual XQual (GhcPass 'Renamed)
_ (L SrcSpanAnnC
ann [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))]
ctxt) LHsExpr (GhcPass 'Renamed)
expr)) =
do { ctxt' <- (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))))
-> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
go [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))]
ctxt
; ty <- go expr
; return (L l (HsQualTy noExtField (L ann ctxt') ty)) }
go (L SrcSpanAnnA
l (HsVar XVar (GhcPass 'Renamed)
_ LIdP (GhcPass 'Renamed)
lname)) =
GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsType (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XTyVar (GhcPass 'Renamed)
-> PromotionFlag
-> LIdP (GhcPass 'Renamed)
-> HsType (GhcPass 'Renamed)
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar (GhcPass 'Renamed)
EpToken "'"
forall a. NoAnn a => a
noAnn PromotionFlag
NotPromoted LIdP (GhcPass 'Renamed)
lname))
go (L SrcSpanAnnA
l (HsApp XApp (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
lhs LHsExpr (GhcPass 'Renamed)
rhs)) =
do { lhs' <- LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
go LHsExpr (GhcPass 'Renamed)
lhs
; rhs' <- go rhs
; return (L l (HsAppTy noExtField lhs' rhs')) }
go (L SrcSpanAnnA
l (HsAppType XAppTypeE (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
lhs LHsWcType (NoGhcTc (GhcPass 'Renamed))
rhs)) =
do { lhs' <- LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
go LHsExpr (GhcPass 'Renamed)
lhs
; rhs' <- unwrap_wc rhs
; return (L l (HsAppKindTy noExtField lhs' rhs')) }
go (L SrcSpanAnnA
l e :: HsExpr (GhcPass 'Renamed)
e@(OpApp XOpApp (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
lhs LHsExpr (GhcPass 'Renamed)
op LHsExpr (GhcPass 'Renamed)
rhs)) =
do { lhs' <- LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
go LHsExpr (GhcPass 'Renamed)
lhs
; op' <- go op
; rhs' <- go rhs
; op_id <- unwrap_op_tv op'
; return (L l (HsOpTy noExtField NotPromoted lhs' op_id rhs')) }
where
unwrap_op_tv :: GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
-> IOEnv (Env TcGblEnv TcLclEnv) (LIdP (GhcPass 'Renamed))
unwrap_op_tv (L SrcSpanAnnA
_ (HsTyVar XTyVar (GhcPass 'Renamed)
_ PromotionFlag
_ LIdP (GhcPass 'Renamed)
op_id)) = LIdP (GhcPass 'Renamed)
-> IOEnv (Env TcGblEnv TcLclEnv) (LIdP (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LIdP (GhcPass 'Renamed)
op_id
unwrap_op_tv GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
_ = TcRnMessage
-> IOEnv (Env TcGblEnv TcLclEnv) (LIdP (GhcPass 'Renamed))
forall a. TcRnMessage -> TcRn a
failWith (TcRnMessage
-> IOEnv (Env TcGblEnv TcLclEnv) (LIdP (GhcPass 'Renamed)))
-> TcRnMessage
-> IOEnv (Env TcGblEnv TcLclEnv) (LIdP (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Renamed) -> TcRnMessage
TcRnIllformedTypeArgument (SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
e)
go (L SrcSpanAnnA
l (HsOverLit XOverLitE (GhcPass 'Renamed)
_ HsOverLit (GhcPass 'Renamed)
lit))
| Just HsTyLit (GhcPass 'Renamed)
tylit <- OverLitVal -> Maybe (HsTyLit (GhcPass 'Renamed))
tyLitFromOverloadedLit (HsOverLit (GhcPass 'Renamed) -> OverLitVal
forall p. HsOverLit p -> OverLitVal
ol_val HsOverLit (GhcPass 'Renamed)
lit)
= GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsType (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XTyLit (GhcPass 'Renamed)
-> HsTyLit (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed)
forall pass. XTyLit pass -> HsTyLit pass -> HsType pass
HsTyLit XTyLit (GhcPass 'Renamed)
NoExtField
noExtField HsTyLit (GhcPass 'Renamed)
tylit))
go (L SrcSpanAnnA
l (HsLit XLitE (GhcPass 'Renamed)
_ HsLit (GhcPass 'Renamed)
lit))
| Just HsTyLit (GhcPass 'Renamed)
tylit <- HsLit (GhcPass 'Renamed) -> Maybe (HsTyLit (GhcPass 'Renamed))
tyLitFromLit HsLit (GhcPass 'Renamed)
lit
= GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsType (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XTyLit (GhcPass 'Renamed)
-> HsTyLit (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed)
forall pass. XTyLit pass -> HsTyLit pass -> HsType pass
HsTyLit XTyLit (GhcPass 'Renamed)
NoExtField
noExtField HsTyLit (GhcPass 'Renamed)
tylit))
go (L SrcSpanAnnA
l (ExplicitTuple XExplicitTuple (GhcPass 'Renamed)
_ [HsTupArg (GhcPass 'Renamed)]
tup_args Boxity
boxity))
| Boxity -> Bool
isBoxed Boxity
boxity
, Just [LHsExpr (GhcPass 'Renamed)]
es <- [HsTupArg (GhcPass 'Renamed)] -> Maybe [LHsExpr (GhcPass 'Renamed)]
forall (p :: Pass).
[HsTupArg (GhcPass p)] -> Maybe [LHsExpr (GhcPass p)]
tupArgsPresent_maybe [HsTupArg (GhcPass 'Renamed)]
tup_args
= do { ts <- (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))))
-> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
go [LHsExpr (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))]
es
; return (L l (HsExplicitTupleTy noExtField ts)) }
go (L SrcSpanAnnA
l (ExplicitList XExplicitList (GhcPass 'Renamed)
_ [LHsExpr (GhcPass 'Renamed)]
es)) =
do { ts <- (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))))
-> [GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))]
-> IOEnv
(Env TcGblEnv TcLclEnv)
[GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
go [LHsExpr (GhcPass 'Renamed)]
[GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))]
es
; return (L l (HsExplicitListTy noExtField NotPromoted ts)) }
go (L SrcSpanAnnA
l (ExprWithTySig XExprWithTySig (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
e LHsSigWcType (NoGhcTc (GhcPass 'Renamed))
sig_ty)) =
do { t <- LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
go LHsExpr (GhcPass 'Renamed)
e
; sig_ki <- (unwrap_sig <=< unwrap_wc) sig_ty
; return (L l (HsKindSig noAnn t sig_ki)) }
where
unwrap_sig :: LHsSigType GhcRn -> TcM (LHsType GhcRn)
unwrap_sig :: LHsSigType (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
unwrap_sig (L SrcSpanAnnA
_ (HsSig XHsSig (GhcPass 'Renamed)
_ HsOuterImplicit{hso_ximplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass
hso_ximplicit=XHsOuterImplicit (GhcPass 'Renamed)
bndrs} LHsType (GhcPass 'Renamed)
body))
| [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
XHsOuterImplicit (GhcPass 'Renamed)
bndrs = GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return LHsType (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
body
| Bool
otherwise = [Name]
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
forall t. [Name] -> TcM t
illegal_implicit_tvs [Name]
XHsOuterImplicit (GhcPass 'Renamed)
bndrs
unwrap_sig (L SrcSpanAnnA
l (HsSig XHsSig (GhcPass 'Renamed)
_ HsOuterExplicit{hso_bndrs :: forall flag pass.
HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]
hso_bndrs=[LHsTyVarBndr Specificity (NoGhcTc (GhcPass 'Renamed))]
bndrs} LHsType (GhcPass 'Renamed)
body)) =
LHsType (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed)))
-> LHsType (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsType (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XForAllTy (GhcPass 'Renamed)
-> HsForAllTelescope (GhcPass 'Renamed)
-> LHsType (GhcPass 'Renamed)
-> HsType (GhcPass 'Renamed)
forall pass.
XForAllTy pass
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy XForAllTy (GhcPass 'Renamed)
NoExtField
noExtField (XHsForAllInvis (GhcPass 'Renamed)
-> [LHsTyVarBndr Specificity (GhcPass 'Renamed)]
-> HsForAllTelescope (GhcPass 'Renamed)
forall pass.
XHsForAllInvis pass
-> [LHsTyVarBndr Specificity pass] -> HsForAllTelescope pass
HsForAllInvis XHsForAllInvis (GhcPass 'Renamed)
forall a. NoAnn a => a
noAnn [LHsTyVarBndr Specificity (NoGhcTc (GhcPass 'Renamed))]
[LHsTyVarBndr Specificity (GhcPass 'Renamed)]
bndrs) LHsType (GhcPass 'Renamed)
body)
go (L SrcSpanAnnA
l (HsPar XPar (GhcPass 'Renamed)
_ LHsExpr (GhcPass 'Renamed)
e)) =
do { t <- LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
go LHsExpr (GhcPass 'Renamed)
e
; return (L l (HsParTy noAnn t)) }
go (L SrcSpanAnnA
l (HsUntypedSplice XUntypedSplice (GhcPass 'Renamed)
splice_result HsUntypedSplice (GhcPass 'Renamed)
splice))
| HsUntypedSpliceTop ThModFinalizers
finalizers HsExpr (GhcPass 'Renamed)
e <- XUntypedSplice (GhcPass 'Renamed)
splice_result
= do { t <- LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
go (SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
e)
; let splice_result' = ThModFinalizers
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
-> HsUntypedSpliceResult
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
forall thing.
ThModFinalizers -> thing -> HsUntypedSpliceResult thing
HsUntypedSpliceTop ThModFinalizers
finalizers GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
t
; return (L l (HsSpliceTy splice_result' splice)) }
go (L SrcSpanAnnA
l (HsUnboundVar XUnboundVar (GhcPass 'Renamed)
_ RdrName
rdr))
| OccName -> Bool
isUnderscore OccName
occ = GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnnA
-> HsType (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l (XWildCardTy (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed)
forall pass. XWildCardTy pass -> HsType pass
HsWildCardTy XWildCardTy (GhcPass 'Renamed)
NoExtField
noExtField))
| OccName -> Bool
startsWithUnderscore OccName
occ =
do { wildcards_enabled <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.NamedWildCards
; if wildcards_enabled
then illegal_wc rdr
else not_in_scope }
| Bool
otherwise = TcM (LHsType (GhcPass 'Renamed))
IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
not_in_scope
where occ :: OccName
occ = RdrName -> OccName
forall name. HasOccName name => name -> OccName
occName RdrName
rdr
not_in_scope :: IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
not_in_scope = TcRnMessage
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
forall a. TcRnMessage -> TcRn a
failWith (TcRnMessage
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed))))
-> TcRnMessage
-> IOEnv
(Env TcGblEnv TcLclEnv)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Renamed)))
forall a b. (a -> b) -> a -> b
$ RdrName -> NotInScopeError -> TcRnMessage
mkTcRnNotInScope RdrName
rdr NotInScopeError
NotInScope
go (L SrcSpanAnnA
l (XExpr (ExpandedThingRn (OrigExpr HsExpr (GhcPass 'Renamed)
orig) HsExpr (GhcPass 'Renamed)
_))) =
LHsExpr (GhcPass 'Renamed) -> TcM (LHsType (GhcPass 'Renamed))
go (SrcSpanAnnA
-> HsExpr (GhcPass 'Renamed)
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l HsExpr (GhcPass 'Renamed)
orig)
go LHsExpr (GhcPass 'Renamed)
e = TcRnMessage -> TcM (LHsType (GhcPass 'Renamed))
forall a. TcRnMessage -> TcRn a
failWith (TcRnMessage -> TcM (LHsType (GhcPass 'Renamed)))
-> TcRnMessage -> TcM (LHsType (GhcPass 'Renamed))
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Renamed) -> TcRnMessage
TcRnIllformedTypeArgument LHsExpr (GhcPass 'Renamed)
e
unwrap_wc :: HsWildCardBndrs GhcRn t -> TcM t
unwrap_wc :: forall t. HsWildCardBndrs (GhcPass 'Renamed) t -> TcM t
unwrap_wc (HsWC XHsWC (GhcPass 'Renamed) t
wcs t
t)
= do { (Name -> IOEnv (Env TcGblEnv TcLclEnv) (ZonkAny 0))
-> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) (ZonkAny 0)
forall t. RdrName -> TcM t
illegal_wc (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) (ZonkAny 0))
-> (Name -> RdrName)
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) (ZonkAny 0)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> RdrName
nameRdrName) [Name]
XHsWC (GhcPass 'Renamed) t
wcs
; t -> IOEnv (Env TcGblEnv TcLclEnv) t
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return t
t }
illegal_wc :: RdrName -> TcM t
illegal_wc :: forall t. RdrName -> TcM t
illegal_wc RdrName
rdr = TcRnMessage -> TcRn t
forall a. TcRnMessage -> TcRn a
failWith (TcRnMessage -> TcRn t) -> TcRnMessage -> TcRn t
forall a b. (a -> b) -> a -> b
$ RdrName -> TcRnMessage
TcRnIllegalNamedWildcardInTypeArgument RdrName
rdr
illegal_implicit_tvs :: [Name] -> TcM t
illegal_implicit_tvs :: forall t. [Name] -> TcM t
illegal_implicit_tvs [Name]
tvs
= do { (Name -> TcRn ()) -> [Name] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TcRnMessage -> TcRn ()
addErr (TcRnMessage -> TcRn ())
-> (Name -> TcRnMessage) -> Name -> TcRn ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> TcRnMessage
TcRnIllegalImplicitTyVarInTypeArgument (RdrName -> TcRnMessage)
-> (Name -> RdrName) -> Name -> TcRnMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> RdrName
nameRdrName) [Name]
tvs
; IOEnv (Env TcGblEnv TcLclEnv) t
forall env a. IOEnv env a
failM }
tc_inst_forall_arg :: ConcreteTyVars
-> (ForAllTyBinder, TcType)
-> LHsWcType GhcRn
-> TcM (TcType, TcType)
tc_inst_forall_arg :: ConcreteTyVars
-> (TyVarBinder, TcType)
-> LHsWcType (GhcPass 'Renamed)
-> TcM (TcType, TcType)
tc_inst_forall_arg ConcreteTyVars
conc_tvs (TyVarBinder
tvb, TcType
inner_ty) LHsWcType (GhcPass 'Renamed)
hs_ty
= do { let tv :: Id
tv = TyVarBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar TyVarBinder
tvb
kind :: TcType
kind = Id -> TcType
tyVarKind Id
tv
tv_nm :: Name
tv_nm = Id -> Name
tyVarName Id
tv
mb_conc :: Maybe ConcreteTvOrigin
mb_conc = ConcreteTyVars -> Name -> Maybe ConcreteTvOrigin
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv ConcreteTyVars
conc_tvs Name
tv_nm
; ty_arg0 <- LHsWcType (GhcPass 'Renamed) -> TcType -> TcM TcType
tcHsTypeApp LHsWcType (GhcPass 'Renamed)
hs_ty TcType
kind
; th_stage <- getStage
; ty_arg <- case mb_conc of
Maybe ConcreteTvOrigin
Nothing -> TcType -> TcM TcType
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
ty_arg0
Just ConcreteTvOrigin
conc
| Brack ThStage
_ (TcPending {}) <- ThStage
th_stage
-> TcType -> TcM TcType
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcType
ty_arg0
| Bool
otherwise
->
do { mco <- HasDebugCallStack =>
FastString -> ConcreteTvOrigin -> TcType -> TcM TcMCoercionN
FastString -> ConcreteTvOrigin -> TcType -> TcM TcMCoercionN
unifyConcrete (OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Name -> OccName) -> Name -> OccName
forall a b. (a -> b) -> a -> b
$ Name
tv_nm) ConcreteTvOrigin
conc TcType
ty_arg0
; return $ case mco of { TcMCoercionN
MRefl -> TcType
ty_arg0; MCo TcCoercionN
co -> HasDebugCallStack => TcCoercionN -> TcType
TcCoercionN -> TcType
coercionRKind TcCoercionN
co } }
; let fun_ty = TyVarBinder -> TcType -> TcType
mkForAllTy TyVarBinder
tvb TcType
inner_ty
in_scope = VarSet -> InScopeSet
mkInScopeSet (ThetaType -> VarSet
tyCoVarsOfTypes [TcType
fun_ty, TcType
ty_arg])
insted_ty = HasDebugCallStack =>
InScopeSet -> [Id] -> ThetaType -> TcType -> TcType
InScopeSet -> [Id] -> ThetaType -> TcType -> TcType
substTyWithInScope InScopeSet
in_scope [Id
tv] [TcType
ty_arg] TcType
inner_ty
; traceTc "tc_inst_forall_arg (VTA/VDQ)" (
vcat [ text "fun_ty" <+> ppr fun_ty
, text "tv" <+> ppr tv <+> dcolon <+> debugPprType kind
, text "ty_arg" <+> debugPprType ty_arg <+> dcolon
<+> debugPprType (typeKind ty_arg)
, text "inner_ty" <+> debugPprType inner_ty
, text "insted_ty" <+> debugPprType insted_ty ])
; return (ty_arg, insted_ty) }
quickLookArg :: QLFlag -> AppCtxt
-> LHsExpr GhcRn
-> Scaled TcSigmaTypeFRR
-> TcM (HsExprArg 'TcpInst)
quickLookArg :: QLFlag
-> AppCtxt
-> LHsExpr (GhcPass 'Renamed)
-> Scaled TcType
-> TcM (HsExprArg 'TcpInst)
quickLookArg QLFlag
NoQL AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
larg Scaled TcType
orig_arg_ty
= AppCtxt
-> LHsExpr (GhcPass 'Renamed)
-> Scaled TcType
-> TcM (HsExprArg 'TcpInst)
skipQuickLook AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
larg Scaled TcType
orig_arg_ty
quickLookArg QLFlag
DoQL AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
larg Scaled TcType
orig_arg_ty
= do { is_rho <- TcType -> TcRnIf TcGblEnv TcLclEnv Bool
tcIsDeepRho (Scaled TcType -> TcType
forall a. Scaled a -> a
scaledThing Scaled TcType
orig_arg_ty)
; traceTc "qla" (ppr orig_arg_ty $$ ppr is_rho)
; if not is_rho
then skipQuickLook ctxt larg orig_arg_ty
else quickLookArg1 ctxt larg orig_arg_ty }
skipQuickLook :: AppCtxt -> LHsExpr GhcRn -> Scaled TcRhoType
-> TcM (HsExprArg 'TcpInst)
skipQuickLook :: AppCtxt
-> LHsExpr (GhcPass 'Renamed)
-> Scaled TcType
-> TcM (HsExprArg 'TcpInst)
skipQuickLook AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
larg Scaled TcType
arg_ty
= HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpInst)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EValArg { ea_ctxt :: AppCtxt
ea_ctxt = AppCtxt
ctxt
, ea_arg :: LHsExpr (GhcPass (XPass 'TcpInst))
ea_arg = LHsExpr (GhcPass 'Renamed)
LHsExpr (GhcPass (XPass 'TcpInst))
larg
, ea_arg_ty :: XEVAType 'TcpInst
ea_arg_ty = Scaled TcType
XEVAType 'TcpInst
arg_ty })
whenQL :: QLFlag -> ZonkM () -> TcM ()
whenQL :: QLFlag -> ZonkM () -> TcRn ()
whenQL QLFlag
DoQL ZonkM ()
thing_inside = ZonkM () -> TcRn ()
forall a. ZonkM a -> TcM a
liftZonkM ZonkM ()
thing_inside
whenQL QLFlag
NoQL ZonkM ()
_ = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tcIsDeepRho :: TcType -> TcM Bool
tcIsDeepRho :: TcType -> TcRnIf TcGblEnv TcLclEnv Bool
tcIsDeepRho TcType
ty
= do { ds_flag <- TcM DeepSubsumptionFlag
getDeepSubsumptionFlag
; go ds_flag ty }
where
go :: DeepSubsumptionFlag -> TcType -> m Bool
go DeepSubsumptionFlag
ds_flag TcType
ty
| TcType -> Bool
isSigmaTy TcType
ty = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Just Id
kappa <- TcType -> Maybe Id
getTyVar_maybe TcType
ty
, Id -> Bool
isQLInstTyVar Id
kappa
= do { info <- Id -> m MetaDetails
forall (m :: * -> *). MonadIO m => Id -> m MetaDetails
readMetaTyVar Id
kappa
; case info of
Indirect TcType
arg_ty' -> DeepSubsumptionFlag -> TcType -> m Bool
go DeepSubsumptionFlag
ds_flag TcType
arg_ty'
MetaDetails
Flexi -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True }
| DeepSubsumptionFlag
Deep <- DeepSubsumptionFlag
ds_flag
, Just (Scaled TcType
_, TcType
res_ty) <- TcType -> Maybe (Scaled TcType, TcType)
tcSplitFunTy_maybe TcType
ty
= DeepSubsumptionFlag -> TcType -> m Bool
go DeepSubsumptionFlag
ds_flag TcType
res_ty
| Bool
otherwise = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isGuardedTy :: TcType -> Bool
isGuardedTy :: TcType -> Bool
isGuardedTy TcType
ty
| Just (TyCon
tc,ThetaType
_) <- HasDebugCallStack => TcType -> Maybe (TyCon, ThetaType)
TcType -> Maybe (TyCon, ThetaType)
tcSplitTyConApp_maybe TcType
ty = TyCon -> Role -> Bool
isGenerativeTyCon TyCon
tc Role
Nominal
| Just {} <- TcType -> Maybe (TcType, TcType)
tcSplitAppTy_maybe TcType
ty = Bool
True
| Bool
otherwise = Bool
False
quickLookArg1 :: AppCtxt -> LHsExpr GhcRn
-> Scaled TcRhoType
-> TcM (HsExprArg 'TcpInst)
quickLookArg1 :: AppCtxt
-> LHsExpr (GhcPass 'Renamed)
-> Scaled TcType
-> TcM (HsExprArg 'TcpInst)
quickLookArg1 AppCtxt
ctxt larg :: LHsExpr (GhcPass 'Renamed)
larg@(L SrcSpanAnnA
_ HsExpr (GhcPass 'Renamed)
arg) sc_arg_ty :: Scaled TcType
sc_arg_ty@(Scaled TcType
_ TcType
orig_arg_rho)
= AppCtxt
-> LHsExpr (GhcPass 'Renamed)
-> TcM (HsExprArg 'TcpInst)
-> TcM (HsExprArg 'TcpInst)
forall a. AppCtxt -> LHsExpr (GhcPass 'Renamed) -> TcM a -> TcM a
addArgCtxt AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
larg (TcM (HsExprArg 'TcpInst) -> TcM (HsExprArg 'TcpInst))
-> TcM (HsExprArg 'TcpInst) -> TcM (HsExprArg 'TcpInst)
forall a b. (a -> b) -> a -> b
$
do { ((rn_fun, fun_ctxt), rn_args) <- HsExpr (GhcPass 'Renamed)
-> TcM ((HsExpr (GhcPass 'Renamed), AppCtxt), [HsExprArg 'TcpRn])
splitHsApps HsExpr (GhcPass 'Renamed)
arg
; mb_fun_ty <- tcInferAppHead_maybe rn_fun
; traceTc "quickLookArg {" $
vcat [ text "arg:" <+> ppr arg
, text "orig_arg_rho:" <+> ppr orig_arg_rho
, text "head:" <+> ppr rn_fun <+> dcolon <+> ppr mb_fun_ty
, text "args:" <+> ppr rn_args ]
; case mb_fun_ty of {
Maybe (HsExpr GhcTc, TcType)
Nothing -> AppCtxt
-> LHsExpr (GhcPass 'Renamed)
-> Scaled TcType
-> TcM (HsExprArg 'TcpInst)
skipQuickLook AppCtxt
ctxt LHsExpr (GhcPass 'Renamed)
larg Scaled TcType
sc_arg_ty ;
Just (HsExpr GhcTc
tc_fun, TcType
fun_sigma) ->
do { let tc_head :: (HsExpr GhcTc, AppCtxt)
tc_head = (HsExpr GhcTc
tc_fun, AppCtxt
fun_ctxt)
; do_ql <- HsExpr (GhcPass 'Renamed) -> TcM QLFlag
wantQuickLook HsExpr (GhcPass 'Renamed)
rn_fun
; ((inst_args, app_res_rho), wanted)
<- captureConstraints $
tcInstFun do_ql True tc_head fun_sigma rn_args
; traceTc "quickLookArg 2" $
vcat [ text "arg:" <+> ppr arg
, text "orig_arg_rho:" <+> ppr orig_arg_rho
, text "app_res_rho:" <+> ppr app_res_rho ]
; arg_influences_enclosing_call
<- if isGuardedTy orig_arg_rho
then return True
else not <$> anyFreeKappa app_res_rho
; when arg_influences_enclosing_call $
qlUnify app_res_rho orig_arg_rho
; traceTc "quickLookArg done }" (ppr rn_fun)
; return (EValArgQL { eaql_ctxt = ctxt
, eaql_arg_ty = sc_arg_ty
, eaql_larg = larg
, eaql_tc_fun = tc_head
, eaql_args = inst_args
, eaql_wanted = wanted
, eaql_encl = arg_influences_enclosing_call
, eaql_res_rho = app_res_rho }) }}}
qlMonoHsWrapper :: HsWrapper -> ZonkM ()
qlMonoHsWrapper :: HsWrapper -> ZonkM ()
qlMonoHsWrapper (WpCompose HsWrapper
w1 HsWrapper
w2) = HsWrapper -> ZonkM ()
qlMonoHsWrapper HsWrapper
w1 ZonkM () -> ZonkM () -> ZonkM ()
forall a b. ZonkM a -> ZonkM b -> ZonkM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HsWrapper -> ZonkM ()
qlMonoHsWrapper HsWrapper
w2
qlMonoHsWrapper (WpTyApp TcType
ty) = TcType -> ZonkM ()
qlMonoTcType TcType
ty
qlMonoHsWrapper HsWrapper
_ = () -> ZonkM ()
forall a. a -> ZonkM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
qlMonoTcType :: TcType -> ZonkM ()
qlMonoTcType :: TcType -> ZonkM ()
qlMonoTcType TcType
ty
= do { String -> SDoc -> ZonkM ()
traceZonk String
"monomorphiseQLInstVars {" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty)
; TcType -> ZonkM ()
go_ty TcType
ty
; String -> SDoc -> ZonkM ()
traceZonk String
"monomorphiseQLInstVars }" SDoc
forall doc. IsOutput doc => doc
empty }
where
go_ty :: TcType -> ZonkM ()
go_ty :: TcType -> ZonkM ()
go_ty TcType
ty = TcMUnit -> ZonkM ()
unTcMUnit ((Id -> TcMUnit) -> TcType -> TcMUnit
forall a. Monoid a => (Id -> a) -> TcType -> a
foldQLInstVars Id -> TcMUnit
go_tv TcType
ty)
go_tv :: TcTyVar -> TcMUnit
go_tv :: Id -> TcMUnit
go_tv Id
tv
| MetaTv { mtv_ref :: TcTyVarDetails -> IORef MetaDetails
mtv_ref = IORef MetaDetails
ref, mtv_tclvl :: TcTyVarDetails -> TcLevel
mtv_tclvl = TcLevel
lvl, mtv_info :: TcTyVarDetails -> MetaInfo
mtv_info = MetaInfo
info } <- Id -> TcTyVarDetails
tcTyVarDetails Id
tv
= Bool -> SDoc -> TcMUnit -> TcMUnit
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (case TcLevel
lvl of TcLevel
QLInstVar -> Bool
True; TcLevel
_ -> Bool
False) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
tv) (TcMUnit -> TcMUnit) -> TcMUnit -> TcMUnit
forall a b. (a -> b) -> a -> b
$
ZonkM () -> TcMUnit
TCMU (ZonkM () -> TcMUnit) -> ZonkM () -> TcMUnit
forall a b. (a -> b) -> a -> b
$ do { String -> SDoc -> ZonkM ()
traceZonk String
"qlMonoTcType" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
tv)
; flex <- IORef MetaDetails -> ZonkM MetaDetails
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef IORef MetaDetails
ref
; case flex of {
Indirect TcType
ty -> TcType -> ZonkM ()
go_ty TcType
ty ;
MetaDetails
Flexi ->
do { let kind :: TcType
kind = Id -> TcType
tyVarKind Id
tv
; TcType -> ZonkM ()
go_ty TcType
kind
; ref2 <- MetaDetails -> ZonkM (IORef MetaDetails)
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef MetaDetails
Flexi
; lvl2 <- getZonkTcLevel
; let details = MetaTv { mtv_info :: MetaInfo
mtv_info = MetaInfo
info
, mtv_ref :: IORef MetaDetails
mtv_ref = IORef MetaDetails
ref2
, mtv_tclvl :: TcLevel
mtv_tclvl = TcLevel
lvl2 }
tv2 = Name -> TcType -> TcTyVarDetails -> Id
mkTcTyVar (Id -> Name
tyVarName Id
tv) TcType
kind TcTyVarDetails
details
; writeTcRef ref (Indirect (mkTyVarTy tv2)) }}}
| Bool
otherwise
= String -> SDoc -> TcMUnit
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"qlMonoTcType" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
tv)
newtype TcMUnit = TCMU { TcMUnit -> ZonkM ()
unTcMUnit :: ZonkM () }
instance Semigroup TcMUnit where
TCMU ZonkM ()
ml <> :: TcMUnit -> TcMUnit -> TcMUnit
<> TCMU ZonkM ()
mr = ZonkM () -> TcMUnit
TCMU (ZonkM ()
ml ZonkM () -> ZonkM () -> ZonkM ()
forall a b. ZonkM a -> ZonkM b -> ZonkM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ZonkM ()
mr)
instance Monoid TcMUnit where
mempty :: TcMUnit
mempty = ZonkM () -> TcMUnit
TCMU (() -> ZonkM ()
forall a. a -> ZonkM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
anyFreeKappa :: TcType -> TcM Bool
anyFreeKappa :: TcType -> TcRnIf TcGblEnv TcLclEnv Bool
anyFreeKappa TcType
ty = TcMBool -> TcRnIf TcGblEnv TcLclEnv Bool
unTcMBool ((Id -> TcMBool) -> TcType -> TcMBool
forall a. Monoid a => (Id -> a) -> TcType -> a
foldQLInstVars Id -> TcMBool
go_tv TcType
ty)
where
go_tv :: Id -> TcMBool
go_tv Id
tv = TcRnIf TcGblEnv TcLclEnv Bool -> TcMBool
TCMB (TcRnIf TcGblEnv TcLclEnv Bool -> TcMBool)
-> TcRnIf TcGblEnv TcLclEnv Bool -> TcMBool
forall a b. (a -> b) -> a -> b
$ do { info <- Id -> IOEnv (Env TcGblEnv TcLclEnv) MetaDetails
forall (m :: * -> *). MonadIO m => Id -> m MetaDetails
readMetaTyVar Id
tv
; case info of
Indirect TcType
ty -> TcType -> TcRnIf TcGblEnv TcLclEnv Bool
anyFreeKappa TcType
ty
MetaDetails
Flexi -> Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True }
newtype TcMBool = TCMB { TcMBool -> TcRnIf TcGblEnv TcLclEnv Bool
unTcMBool :: TcM Bool }
instance Semigroup TcMBool where
TCMB TcRnIf TcGblEnv TcLclEnv Bool
ml <> :: TcMBool -> TcMBool -> TcMBool
<> TCMB TcRnIf TcGblEnv TcLclEnv Bool
mr = TcRnIf TcGblEnv TcLclEnv Bool -> TcMBool
TCMB (do { l <- TcRnIf TcGblEnv TcLclEnv Bool
ml; if l then return True else mr })
instance Monoid TcMBool where
mempty :: TcMBool
mempty = TcRnIf TcGblEnv TcLclEnv Bool -> TcMBool
TCMB (Bool -> TcRnIf TcGblEnv TcLclEnv Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
foldQLInstVars :: forall a. Monoid a => (TcTyVar -> a) -> TcType -> a
{-# INLINE foldQLInstVars #-}
foldQLInstVars :: forall a. Monoid a => (Id -> a) -> TcType -> a
foldQLInstVars Id -> a
check_tv TcType
ty
= TcType -> a
do_ty TcType
ty
where
(TcType -> a
do_ty, ThetaType -> a
_, TcCoercionN -> a
_, [TcCoercionN] -> a
_) = TyCoFolder () a
-> ()
-> (TcType -> a, ThetaType -> a, TcCoercionN -> a,
[TcCoercionN] -> a)
forall a env.
Monoid a =>
TyCoFolder env a
-> env
-> (TcType -> a, ThetaType -> a, TcCoercionN -> a,
[TcCoercionN] -> a)
foldTyCo TyCoFolder () a
folder ()
folder :: TyCoFolder () a
folder :: TyCoFolder () a
folder = TyCoFolder { tcf_view :: TcType -> Maybe TcType
tcf_view = TcType -> Maybe TcType
noView
, tcf_tyvar :: () -> Id -> a
tcf_tyvar = () -> Id -> a
do_tv, tcf_covar :: () -> Id -> a
tcf_covar = () -> Id -> a
forall a. Monoid a => a
mempty
, tcf_hole :: () -> CoercionHole -> a
tcf_hole = () -> CoercionHole -> a
do_hole, tcf_tycobinder :: () -> Id -> ForAllTyFlag -> ()
tcf_tycobinder = () -> Id -> ForAllTyFlag -> ()
forall {p} {p} {p}. p -> p -> p -> ()
do_bndr }
do_bndr :: p -> p -> p -> ()
do_bndr p
_ p
_ p
_ = ()
do_hole :: () -> CoercionHole -> a
do_hole ()
_ CoercionHole
hole = TcType -> a
do_ty (Id -> TcType
coVarKind (CoercionHole -> Id
coHoleCoVar CoercionHole
hole))
do_tv :: () -> TcTyVar -> a
do_tv :: () -> Id -> a
do_tv ()
_ Id
tv | Id -> Bool
isQLInstTyVar Id
tv = Id -> a
check_tv Id
tv
| Bool
otherwise = a
forall a. Monoid a => a
mempty
qlUnify :: TcType -> TcType -> TcM ()
qlUnify :: TcType -> TcType -> TcRn ()
qlUnify TcType
ty1 TcType
ty2
= do { String -> SDoc -> TcRn ()
traceTc String
"qlUnify" (TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty1 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ TcType -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcType
ty2)
; TcType -> TcType -> TcRn ()
go TcType
ty1 TcType
ty2 }
where
go :: TcType -> TcType
-> TcM ()
go :: TcType -> TcType -> TcRn ()
go (TyVarTy Id
tv) TcType
ty2
| Id -> Bool
isMetaTyVar Id
tv = Id -> TcType -> TcRn ()
go_kappa Id
tv TcType
ty2
go TcType
ty1 (TyVarTy Id
tv)
| Id -> Bool
isMetaTyVar Id
tv = Id -> TcType -> TcRn ()
go_kappa Id
tv TcType
ty1
go (CastTy TcType
ty1 TcCoercionN
_) TcType
ty2 = TcType -> TcType -> TcRn ()
go TcType
ty1 TcType
ty2
go TcType
ty1 (CastTy TcType
ty2 TcCoercionN
_) = TcType -> TcType -> TcRn ()
go TcType
ty1 TcType
ty2
go (TyConApp TyCon
tc1 []) (TyConApp TyCon
tc2 [])
| TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go TcType
rho1 TcType
rho2
| Just TcType
rho1 <- TcType -> Maybe TcType
coreView TcType
rho1 = TcType -> TcType -> TcRn ()
go TcType
rho1 TcType
rho2
| Just TcType
rho2 <- TcType -> Maybe TcType
coreView TcType
rho2 = TcType -> TcType -> TcRn ()
go TcType
rho1 TcType
rho2
go (TyConApp TyCon
tc1 ThetaType
tys1) (TyConApp TyCon
tc2 ThetaType
tys2)
| TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2
, Bool -> Bool
not (TyCon -> Bool
isTypeFamilyTyCon TyCon
tc1)
, ThetaType
tys1 ThetaType -> ThetaType -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` ThetaType
tys2
= (TcType -> TcType -> TcRn ()) -> ThetaType -> ThetaType -> TcRn ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ TcType -> TcType -> TcRn ()
go ThetaType
tys1 ThetaType
tys2
go (FunTy { ft_af :: TcType -> FunTyFlag
ft_af = FunTyFlag
af1, ft_arg :: TcType -> TcType
ft_arg = TcType
arg1, ft_res :: TcType -> TcType
ft_res = TcType
res1, ft_mult :: TcType -> TcType
ft_mult = TcType
mult1 })
(FunTy { ft_af :: TcType -> FunTyFlag
ft_af = FunTyFlag
af2, ft_arg :: TcType -> TcType
ft_arg = TcType
arg2, ft_res :: TcType -> TcType
ft_res = TcType
res2, ft_mult :: TcType -> TcType
ft_mult = TcType
mult2 })
| FunTyFlag
af1 FunTyFlag -> FunTyFlag -> Bool
forall a. Eq a => a -> a -> Bool
== FunTyFlag
af2
= do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FunTyFlag -> Bool
isVisibleFunArg FunTyFlag
af1) (TcType -> TcType -> TcRn ()
go TcType
arg1 TcType
arg2)
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FunTyFlag -> Bool
isFUNArg FunTyFlag
af1) (TcType -> TcType -> TcRn ()
go TcType
mult1 TcType
mult2)
; TcType -> TcType -> TcRn ()
go TcType
res1 TcType
res2 }
go (AppTy TcType
t1a TcType
t1b) TcType
ty2
| Just (TcType
t2a, TcType
t2b) <- TcType -> Maybe (TcType, TcType)
tcSplitAppTyNoView_maybe TcType
ty2
= do { TcType -> TcType -> TcRn ()
go TcType
t1a TcType
t2a; TcType -> TcType -> TcRn ()
go TcType
t1b TcType
t2b }
go TcType
ty1 (AppTy TcType
t2a TcType
t2b)
| Just (TcType
t1a, TcType
t1b) <- TcType -> Maybe (TcType, TcType)
tcSplitAppTyNoView_maybe TcType
ty1
= do { TcType -> TcType -> TcRn ()
go TcType
t1a TcType
t2a; TcType -> TcType -> TcRn ()
go TcType
t1b TcType
t2b }
go TcType
_ TcType
_ = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_kappa :: Id -> TcType -> TcRn ()
go_kappa Id
kappa TcType
ty2
= Bool -> SDoc -> TcRn () -> TcRn ()
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Id -> Bool
isMetaTyVar Id
kappa) (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
kappa) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
do { info <- Id -> IOEnv (Env TcGblEnv TcLclEnv) MetaDetails
forall (m :: * -> *). MonadIO m => Id -> m MetaDetails
readMetaTyVar Id
kappa
; case info of
Indirect TcType
ty1 -> TcType -> TcType -> TcRn ()
go TcType
ty1 TcType
ty2
MetaDetails
Flexi -> do { ty2 <- ZonkM TcType -> TcM TcType
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM TcType -> TcM TcType) -> ZonkM TcType -> TcM TcType
forall a b. (a -> b) -> a -> b
$ TcType -> ZonkM TcType
zonkTcType TcType
ty2
; go_flexi kappa ty2 } }
go_flexi :: Id -> TcType -> TcRn ()
go_flexi Id
kappa (TyVarTy Id
tv2)
| Id -> Int
lhsPriority Id
tv2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Id -> Int
lhsPriority Id
kappa
= Id -> TcType -> TcRn ()
go_flexi1 Id
tv2 (Id -> TcType
TyVarTy Id
kappa)
go_flexi Id
kappa TcType
ty2
= Id -> TcType -> TcRn ()
go_flexi1 Id
kappa TcType
ty2
go_flexi1 :: Id -> TcType -> TcRn ()
go_flexi1 Id
kappa TcType
ty2
|
UnifyCheckCaller -> Id -> TcType -> Bool
simpleUnifyCheck UnifyCheckCaller
UC_QuickLook Id
kappa TcType
ty2
= do { co <- Maybe TypedThing -> TcType -> TcType -> TcM TcCoercionN
unifyKind (TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just (TcType -> TypedThing
TypeThing TcType
ty2)) TcType
ty2_kind TcType
kappa_kind
; let ty2' = TcType -> TcCoercionN -> TcType
mkCastTy TcType
ty2 TcCoercionN
co
; traceTc "qlUnify:update" $
ppr kappa <+> text ":=" <+> ppr ty2
; liftZonkM $ writeMetaTyVar kappa ty2' }
| Bool
otherwise
= () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
kappa_kind :: TcType
kappa_kind = Id -> TcType
tyVarKind Id
kappa
ty2_kind :: TcType
ty2_kind = HasDebugCallStack => TcType -> TcType
TcType -> TcType
typeKind TcType
ty2
isTagToEnum :: HsExpr GhcTc -> Bool
isTagToEnum :: HsExpr GhcTc -> Bool
isTagToEnum (HsVar XVar GhcTc
_ (L SrcSpanAnnN
_ Id
fun_id)) = Id
fun_id Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
tagToEnumKey
isTagToEnum HsExpr GhcTc
_ = Bool
False
tcTagToEnum :: (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc]
-> TcRhoType
-> TcM (HsExpr GhcTc)
tcTagToEnum :: (HsExpr GhcTc, AppCtxt)
-> [HsExprArg 'TcpTc] -> TcType -> TcM (HsExpr GhcTc)
tcTagToEnum (HsExpr GhcTc
tc_fun, AppCtxt
fun_ctxt) [HsExprArg 'TcpTc]
tc_args TcType
res_ty
| [HsExprArg 'TcpTc
val_arg] <- (HsExprArg 'TcpTc -> Bool)
-> [HsExprArg 'TcpTc] -> [HsExprArg 'TcpTc]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool)
-> (HsExprArg 'TcpTc -> Bool) -> HsExprArg 'TcpTc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsExprArg 'TcpTc -> Bool
forall (id :: TcPass). HsExprArg id -> Bool
isHsValArg) [HsExprArg 'TcpTc]
tc_args
= do { res_ty <- ZonkM TcType -> TcM TcType
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM TcType -> TcM TcType) -> ZonkM TcType -> TcM TcType
forall a b. (a -> b) -> a -> b
$ TcType -> ZonkM TcType
zonkTcType TcType
res_ty
; case tcSplitTyConApp_maybe res_ty of {
Maybe (TyCon, ThetaType)
Nothing -> do { TcRnMessage -> TcRn ()
addErrTc (TcType -> TcRnMessage
TcRnTagToEnumUnspecifiedResTy TcType
res_ty)
; TcM (HsExpr GhcTc)
vanilla_result } ;
Just (TyCon
tc, ThetaType
tc_args) ->
do {
; fam_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
; case tcLookupDataFamInst_maybe fam_envs tc tc_args of {
Maybe (TyCon, ThetaType, TcCoercionN)
Nothing -> do { TcType -> TyCon -> TcRn ()
check_enumeration TcType
res_ty TyCon
tc
; TcM (HsExpr GhcTc)
vanilla_result } ;
Just (TyCon
rep_tc, ThetaType
rep_args, TcCoercionN
coi) ->
do {
TcType -> TyCon -> TcRn ()
check_enumeration TcType
res_ty TyCon
rep_tc
; let rep_ty :: TcType
rep_ty = TyCon -> ThetaType -> TcType
mkTyConApp TyCon
rep_tc ThetaType
rep_args
tc_fun' :: HsExpr GhcTc
tc_fun' = HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap (TcType -> HsWrapper
WpTyApp TcType
rep_ty) HsExpr GhcTc
tc_fun
df_wrap :: HsWrapper
df_wrap = TcCoercionN -> HsWrapper
mkWpCastR (TcCoercionN -> TcCoercionN
mkSymCo TcCoercionN
coi)
tc_expr :: HsExpr GhcTc
tc_expr = (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (HsExpr GhcTc
tc_fun', AppCtxt
fun_ctxt) [HsExprArg 'TcpTc
val_arg]
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
df_wrap HsExpr GhcTc
tc_expr) }}}}}
| Bool
otherwise
= TcRnMessage -> TcM (HsExpr GhcTc)
forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
TcRnTagToEnumMissingValArg
where
vanilla_result :: TcM (HsExpr GhcTc)
vanilla_result = HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpTc] -> HsExpr GhcTc
rebuildHsApps (HsExpr GhcTc
tc_fun, AppCtxt
fun_ctxt) [HsExprArg 'TcpTc]
tc_args)
check_enumeration :: TcType -> TyCon -> TcRn ()
check_enumeration TcType
ty' TyCon
tc
|
TyCon -> Bool
isTypeDataTyCon TyCon
tc = TcRnMessage -> TcRn ()
addErrTc (TcType -> TcRnMessage
TcRnTagToEnumResTyTypeData TcType
ty')
| TyCon -> Bool
isEnumerationTyCon TyCon
tc = () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = TcRnMessage -> TcRn ()
addErrTc (TcType -> TcRnMessage
TcRnTagToEnumResTyNotAnEnum TcType
ty')
rejectRepPolyNewtypes :: (HsExpr GhcTc, AppCtxt)
-> TcRhoType
-> TcM ()
rejectRepPolyNewtypes :: (HsExpr GhcTc, AppCtxt) -> TcType -> TcRn ()
rejectRepPolyNewtypes (HsExpr GhcTc
fun,AppCtxt
_) TcType
app_res_rho = case HsExpr GhcTc
fun of
XExpr (ConLikeTc (RealDataCon DataCon
con) [Id]
_ [Scaled TcType]
_)
| DataCon -> Bool
isNewDataCon DataCon
con
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TyCon -> Bool
tcHasFixedRuntimeRep (TyCon -> Bool) -> TyCon -> Bool
forall a b. (a -> b) -> a -> b
$ DataCon -> TyCon
dataConTyCon DataCon
con
, Just (FunTyFlag
_rem_arg_af, TcType
_rem_arg_mult, TcType
rem_arg_ty, TcType
_nt_res_ty)
<- TcType -> Maybe (FunTyFlag, TcType, TcType, TcType)
splitFunTy_maybe TcType
app_res_rho
-> do { let frr_ctxt :: FixedRuntimeRepContext
frr_ctxt = DataCon -> FixedRuntimeRepContext
FRRRepPolyUnliftedNewtype DataCon
con
; HasDebugCallStack => FixedRuntimeRepContext -> TcType -> TcRn ()
FixedRuntimeRepContext -> TcType -> TcRn ()
hasFixedRuntimeRep_syntactic FixedRuntimeRepContext
frr_ctxt TcType
rem_arg_ty }
HsExpr GhcTc
_ -> () -> TcRn ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc
tcExprPrag :: HsPragE (GhcPass 'Renamed) -> HsPragE GhcTc
tcExprPrag (HsPragSCC XSCC (GhcPass 'Renamed)
x1 StringLiteral
ann) = XSCC GhcTc -> StringLiteral -> HsPragE GhcTc
forall p. XSCC p -> StringLiteral -> HsPragE p
HsPragSCC XSCC (GhcPass 'Renamed)
XSCC GhcTc
x1 StringLiteral
ann