{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecursiveDo #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Gen.HsType (
kcClassSigType, tcClassSigType,
tcHsSigType, tcHsSigWcType,
tcHsPartialSigType,
tcStandaloneKindSig,
funsSigCtxt, addSigCtxt, pprSigCtxt,
tcHsClsInstType,
tcHsDeriv, tcDerivStrategy,
tcHsTypeApp,
UserTypeCtxt(..),
bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,
bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,
bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,
bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,
bindOuterFamEqnTKBndrs_Q_Tv, bindOuterFamEqnTKBndrs,
tcOuterTKBndrs, scopedSortOuter, outerTyVars, outerTyVarBndrs,
bindOuterSigTKBndrs_Tv,
tcExplicitTKBndrs,
bindNamedWildCardBinders,
bindTyClTyVars, bindTyClTyVarsAndZonk,
tcFamTyPats,
etaExpandAlgTyCon, tcbVisibilities,
zonkAndScopedSort,
InitialKindStrategy(..),
SAKS_or_CUSK(..),
ContextKind(..),
kcDeclHeader, checkForDuplicateScopedTyVars,
tcHsLiftedType, tcHsOpenType,
tcHsLiftedTypeNC, tcHsOpenTypeNC,
tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated,
tcCheckLHsType,
tcHsContext, tcLHsPredType,
kindGeneralizeAll,
tcLHsKindSig, checkDataKindSig, DataSort(..),
checkClassKindSig,
tcMult,
tcHsPatSigType,
HoleMode(..),
funAppCtxt, addTyConFlavCtxt
) where
import GHC.Prelude
import GHC.Hs
import GHC.Rename.Utils
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Origin
import GHC.Core.Predicate
import GHC.Tc.Types.Constraint
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcMType
import GHC.Tc.Validity
import GHC.Tc.Utils.Unify
import GHC.IfaceToCore
import GHC.Tc.Solver
import GHC.Tc.Utils.Zonk
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN,
tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs )
import GHC.Core.Type
import GHC.Builtin.Types.Prim
import GHC.Types.Error
import GHC.Types.Name.Env
import GHC.Types.Name.Reader( lookupLocalRdrOcc )
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Core.TyCon
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.Class
import GHC.Types.Name
import GHC.Types.Var.Env
import GHC.Builtin.Types
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Utils.Misc
import GHC.Types.Unique.Supply
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Builtin.Names hiding ( wildCardName )
import GHC.Driver.Session
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.FastString
import GHC.Data.List.SetOps
import GHC.Data.Maybe
import GHC.Data.Bag( unitBag )
import Data.Function ( on )
import Data.List.NonEmpty as NE( NonEmpty(..), nubBy )
import Data.List ( find, mapAccumL )
import Control.Monad
import Data.Tuple( swap )
funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt
funsSigCtxt :: [GenLocated SrcSpanAnnN Name] -> UserTypeCtxt
funsSigCtxt (L SrcSpanAnnN
_ Name
name1 : [GenLocated SrcSpanAnnN Name]
_) = Name -> ReportRedundantConstraints -> UserTypeCtxt
FunSigCtxt Name
name1 ReportRedundantConstraints
NoRRC
funsSigCtxt [] = String -> UserTypeCtxt
forall a. String -> a
panic String
"funSigCtxt"
addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt :: forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt LocatedA hs_ty
hs_ty TcM a
thing_inside
= SrcSpan -> TcM a -> TcM a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (LocatedA hs_ty -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LocatedA hs_ty
hs_ty) (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 (UserTypeCtxt -> LocatedA hs_ty -> SDoc
forall hs_ty.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> SDoc
pprSigCtxt UserTypeCtxt
ctxt LocatedA hs_ty
hs_ty) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc
pprSigCtxt :: forall hs_ty.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> SDoc
pprSigCtxt UserTypeCtxt
ctxt LocatedA hs_ty
hs_ty
| Just Name
n <- UserTypeCtxt -> Maybe Name
isSigMaybe UserTypeCtxt
ctxt
= SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the type signature:")
Arity
2 (Name -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Name
n SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LocatedA hs_ty -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedA hs_ty
hs_ty)
| Bool
otherwise
= SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"In" SDoc -> SDoc -> SDoc
<+> UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt SDoc -> SDoc -> SDoc
<> SDoc
colon)
Arity
2 (LocatedA hs_ty -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedA hs_ty
hs_ty)
tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
tcHsSigWcType UserTypeCtxt
ctxt LHsSigWcType GhcRn
sig_ty = UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType UserTypeCtxt
ctxt (LHsSigWcType GhcRn -> LHsSigType GhcRn
forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType GhcRn
sig_ty)
kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM ()
kcClassSigType :: [GenLocated SrcSpanAnnN Name] -> LHsSigType GhcRn -> TcM ()
kcClassSigType [GenLocated SrcSpanAnnN Name]
names
sig_ty :: LHsSigType GhcRn
sig_ty@(L SrcSpanAnnA
_ (HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcRn
hs_ty }))
= UserTypeCtxt
-> GenLocated SrcSpanAnnA (HsSigType GhcRn) -> TcM () -> TcM ()
forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt ([GenLocated SrcSpanAnnN Name] -> UserTypeCtxt
funsSigCtxt [GenLocated SrcSpanAnnN Name]
names) LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
sig_ty (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
do { (HsOuterTyVarBndrs Specificity GhcTc, Type)
_ <- HsOuterSigTyVarBndrs GhcRn
-> TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
forall a.
HsOuterSigTyVarBndrs GhcRn
-> TcM a -> TcM (HsOuterTyVarBndrs Specificity GhcTc, a)
bindOuterSigTKBndrs_Tv HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs (TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type))
-> TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
liftedTypeKind
; () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return () }
tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type
tcClassSigType :: [GenLocated SrcSpanAnnN Name] -> LHsSigType GhcRn -> TcM Type
tcClassSigType [GenLocated SrcSpanAnnN Name]
names LHsSigType GhcRn
sig_ty
= UserTypeCtxt
-> GenLocated SrcSpanAnnA (HsSigType GhcRn) -> TcM Type -> TcM Type
forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
sig_ctxt LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
sig_ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
do { SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo SkolemInfoAnon
skol_info_anon
; (Implication
implic, Type
ty) <- SkolemInfo
-> LHsSigType GhcRn -> ContextKind -> TcM (Implication, Type)
tc_lhs_sig_type SkolemInfo
skol_info LHsSigType GhcRn
sig_ty (Type -> ContextKind
TheKind Type
liftedTypeKind)
; Implication -> TcM ()
emitImplication Implication
implic
; Type -> TcM Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty }
where
sig_ctxt :: UserTypeCtxt
sig_ctxt = [GenLocated SrcSpanAnnN Name] -> UserTypeCtxt
funsSigCtxt [GenLocated SrcSpanAnnN Name]
names
skol_info_anon :: SkolemInfoAnon
skol_info_anon = UserTypeCtxt -> SkolemInfoAnon
SigTypeSkol UserTypeCtxt
sig_ctxt
tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType UserTypeCtxt
ctxt LHsSigType GhcRn
sig_ty
= UserTypeCtxt
-> GenLocated SrcSpanAnnA (HsSigType GhcRn) -> TcM Type -> TcM Type
forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
sig_ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcM ()
traceTc String
"tcHsSigType {" (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
sig_ty)
; SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo SkolemInfoAnon
skol_info
; (Implication
implic, Type
ty) <- SkolemInfo
-> LHsSigType GhcRn -> ContextKind -> TcM (Implication, Type)
tc_lhs_sig_type SkolemInfo
skol_info LHsSigType GhcRn
sig_ty (UserTypeCtxt -> ContextKind
expectedKindInCtxt UserTypeCtxt
ctxt)
; String -> SDoc -> TcM ()
traceTc String
"tcHsSigType 2" (Implication -> SDoc
forall a. Outputable a => a -> SDoc
ppr Implication
implic)
; WantedConstraints -> TcM ()
simplifyAndEmitFlatConstraints (Bag Implication -> WantedConstraints
mkImplicWC (Implication -> Bag Implication
forall a. a -> Bag a
unitBag Implication
implic))
; Type
ty <- Type -> TcM Type
zonkTcType Type
ty
; UserTypeCtxt -> Type -> TcM ()
checkValidType UserTypeCtxt
ctxt Type
ty
; String -> SDoc -> TcM ()
traceTc String
"end tcHsSigType }" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
; Type -> TcM Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty }
where
skol_info :: SkolemInfoAnon
skol_info = UserTypeCtxt -> SkolemInfoAnon
SigTypeSkol UserTypeCtxt
ctxt
tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn
-> ContextKind -> TcM (Implication, TcType)
tc_lhs_sig_type :: SkolemInfo
-> LHsSigType GhcRn -> ContextKind -> TcM (Implication, Type)
tc_lhs_sig_type SkolemInfo
skol_info full_hs_ty :: LHsSigType GhcRn
full_hs_ty@(L SrcSpanAnnA
loc (HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs
, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcRn
hs_ty })) ContextKind
ctxt_kind
= SrcSpanAnnA -> TcM (Implication, Type) -> TcM (Implication, Type)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (Implication, Type) -> TcM (Implication, Type))
-> TcM (Implication, Type) -> TcM (Implication, Type)
forall a b. (a -> b) -> a -> b
$
do { (TcLevel
tc_lvl, WantedConstraints
wanted, (Type
exp_kind, (HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs, Type
ty)))
<- String
-> TcM (Type, (HsOuterTyVarBndrs Specificity GhcTc, Type))
-> TcM
(TcLevel, WantedConstraints,
(Type, (HsOuterTyVarBndrs Specificity GhcTc, Type)))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tc_lhs_sig_type" (TcM (Type, (HsOuterTyVarBndrs Specificity GhcTc, Type))
-> TcM
(TcLevel, WantedConstraints,
(Type, (HsOuterTyVarBndrs Specificity GhcTc, Type))))
-> TcM (Type, (HsOuterTyVarBndrs Specificity GhcTc, Type))
-> TcM
(TcLevel, WantedConstraints,
(Type, (HsOuterTyVarBndrs Specificity GhcTc, Type)))
forall a b. (a -> b) -> a -> b
$
do { Type
exp_kind <- ContextKind -> TcM Type
newExpectedKind ContextKind
ctxt_kind
; (HsOuterTyVarBndrs Specificity GhcTc, Type)
stuff <- SkolemInfo
-> HsOuterSigTyVarBndrs GhcRn
-> TcM Type
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrs SkolemInfo
skol_info HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs (TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type))
-> TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
exp_kind
; (Type, (HsOuterTyVarBndrs Specificity GhcTc, Type))
-> TcM (Type, (HsOuterTyVarBndrs Specificity GhcTc, Type))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
exp_kind, (HsOuterTyVarBndrs Specificity GhcTc, Type)
stuff) }
; CandidatesQTvs
exp_kind_dvs <- Type -> TcM CandidatesQTvs
candidateQTyVarsOfType Type
exp_kind
; CandidatesQTvs -> (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM ()
doNotQuantifyTyVars CandidatesQTvs
exp_kind_dvs (Type -> TidyEnv -> TcM (TidyEnv, SDoc)
mk_doc Type
exp_kind)
; String -> SDoc -> TcM ()
traceTc String
"tc_lhs_sig_type" (HsOuterSigTyVarBndrs GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs SDoc -> SDoc -> SDoc
$$ HsOuterTyVarBndrs Specificity GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs)
; HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs <- HsOuterTyVarBndrs Specificity GhcTc
-> TcM (HsOuterTyVarBndrs Specificity GhcTc)
forall flag.
HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc)
scopedSortOuter HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs
; let [InvisTVBinder]
outer_tv_bndrs :: [InvisTVBinder] = HsOuterTyVarBndrs Specificity GhcTc -> [InvisTVBinder]
outerTyVarBndrs HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs
ty1 :: Type
ty1 = [InvisTVBinder] -> Type -> Type
mkInvisForAllTys [InvisTVBinder]
outer_tv_bndrs Type
ty
; [TyVar]
kvs <- SkolemInfo -> WantedConstraints -> Type -> TcM [TyVar]
kindGeneralizeSome SkolemInfo
skol_info WantedConstraints
wanted Type
ty1
; Implication
implic <- SkolemInfoAnon
-> [TyVar] -> TcLevel -> WantedConstraints -> TcM Implication
buildTvImplication (SkolemInfo -> SkolemInfoAnon
getSkolemInfo SkolemInfo
skol_info) [TyVar]
kvs TcLevel
tc_lvl WantedConstraints
wanted
; (Implication, Type) -> TcM (Implication, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Implication
implic, [TyVar] -> Type -> Type
mkInfForAllTys [TyVar]
kvs Type
ty1) }
where
mk_doc :: Type -> TidyEnv -> TcM (TidyEnv, SDoc)
mk_doc Type
exp_kind TidyEnv
tidy_env
= do { (TidyEnv
tidy_env2, Type
exp_kind) <- TidyEnv -> Type -> TcM (TidyEnv, Type)
zonkTidyTcType TidyEnv
tidy_env Type
exp_kind
; (TidyEnv, SDoc) -> TcM (TidyEnv, SDoc)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
tidy_env2, SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"The kind" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp_kind)
Arity
2 (String -> SDoc
text String
"of type signature:" SDoc -> SDoc -> SDoc
<+> GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
full_hs_ty)) }
tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)
tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Type)
tcStandaloneKindSig (L SrcSpanAnnA
_ (StandaloneKindSig XStandaloneKindSig GhcRn
_ (L SrcSpanAnnN
_ Name
name) LHsSigType GhcRn
ksig))
= UserTypeCtxt
-> GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> TcM (Name, Type)
-> TcM (Name, Type)
forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
ksig (TcM (Name, Type) -> TcM (Name, Type))
-> TcM (Name, Type) -> TcM (Name, Type)
forall a b. (a -> b) -> a -> b
$
do { Type
kind <- TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tc_top_lhs_type TypeOrKind
KindLevel UserTypeCtxt
ctxt LHsSigType GhcRn
ksig
; UserTypeCtxt -> Type -> TcM ()
checkValidType UserTypeCtxt
ctxt Type
kind
; (Name, Type) -> TcM (Name, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, Type
kind) }
where
ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
StandaloneKindSigCtxt Name
name
tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcTopLHsType UserTypeCtxt
ctxt LHsSigType GhcRn
lsig_ty
= TcM Type -> TcM Type
forall r. TcM r -> TcM r
checkNoErrs (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tc_top_lhs_type TypeOrKind
TypeLevel UserTypeCtxt
ctxt LHsSigType GhcRn
lsig_ty
tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tc_top_lhs_type TypeOrKind
tyki UserTypeCtxt
ctxt (L SrcSpanAnnA
loc sig_ty :: HsSigType GhcRn
sig_ty@(HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs
, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcRn
body }))
= SrcSpanAnnA -> TcM Type -> TcM Type
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcM ()
traceTc String
"tc_top_lhs_type {" (HsSigType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsSigType GhcRn
sig_ty)
; SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo SkolemInfoAnon
skol_info_anon
; (TcLevel
tclvl, WantedConstraints
wanted, (HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs, Type
ty))
<- String
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
-> TcM
(TcLevel, WantedConstraints,
(HsOuterTyVarBndrs Specificity GhcTc, Type))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tc_top_lhs_type" (TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
-> TcM
(TcLevel, WantedConstraints,
(HsOuterTyVarBndrs Specificity GhcTc, Type)))
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
-> TcM
(TcLevel, WantedConstraints,
(HsOuterTyVarBndrs Specificity GhcTc, Type))
forall a b. (a -> b) -> a -> b
$
SkolemInfo
-> HsOuterSigTyVarBndrs GhcRn
-> TcM Type
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrs SkolemInfo
skol_info HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs (TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type))
-> TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
do { Type
kind <- ContextKind -> TcM Type
newExpectedKind (UserTypeCtxt -> ContextKind
expectedKindInCtxt UserTypeCtxt
ctxt)
; TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type (TypeOrKind -> TcTyMode
mkMode TypeOrKind
tyki) LHsType GhcRn
body Type
kind }
; HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs <- HsOuterTyVarBndrs Specificity GhcTc
-> TcM (HsOuterTyVarBndrs Specificity GhcTc)
forall flag.
HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc)
scopedSortOuter HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs
; let outer_tv_bndrs :: [InvisTVBinder]
outer_tv_bndrs = HsOuterTyVarBndrs Specificity GhcTc -> [InvisTVBinder]
outerTyVarBndrs HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs
ty1 :: Type
ty1 = [InvisTVBinder] -> Type -> Type
mkInvisForAllTys [InvisTVBinder]
outer_tv_bndrs Type
ty
; [TyVar]
kvs <- SkolemInfo -> Type -> TcM [TyVar]
kindGeneralizeAll SkolemInfo
skol_info Type
ty1
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcM ()
reportUnsolvedEqualities SkolemInfo
skol_info [TyVar]
kvs TcLevel
tclvl WantedConstraints
wanted
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; Type
final_ty <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze ([TyVar] -> Type -> Type
mkInfForAllTys [TyVar]
kvs Type
ty1)
; String -> SDoc -> TcM ()
traceTc String
"tc_top_lhs_type }" ([SDoc] -> SDoc
vcat [HsSigType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsSigType GhcRn
sig_ty, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
final_ty])
; Type -> TcM Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
final_ty }
where
skol_info_anon :: SkolemInfoAnon
skol_info_anon = UserTypeCtxt -> SkolemInfoAnon
SigTypeSkol UserTypeCtxt
ctxt
tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])
tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Type])
tcHsDeriv LHsSigType GhcRn
hs_ty
= do { Type
ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcTopLHsType UserTypeCtxt
DerivClauseCtxt LHsSigType GhcRn
hs_ty
; let ([TyVar]
tvs, Type
pred) = Type -> ([TyVar], Type)
splitForAllTyCoVars Type
ty
([Scaled Type]
kind_args, Type
_) = Type -> ([Scaled Type], Type)
splitFunTys ((() :: Constraint) => Type -> Type
Type -> Type
tcTypeKind Type
pred)
; case Type -> Maybe (Class, [Type])
getClassPredTys_maybe Type
pred of
Just (Class
cls, [Type]
tys) -> ([TyVar], Class, [Type], [Type])
-> TcM ([TyVar], Class, [Type], [Type])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
tvs, Class
cls, [Type]
tys, (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
kind_args)
Maybe (Class, [Type])
Nothing -> TcRnMessage -> TcM ([TyVar], Class, [Type], [Type])
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM ([TyVar], Class, [Type], [Type]))
-> TcRnMessage -> TcM ([TyVar], Class, [Type], [Type])
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
(String -> SDoc
text String
"Illegal deriving item" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_ty)) }
tcDerivStrategy :: Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar])
tcDerivStrategy :: Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
tcDerivStrategy Maybe (LDerivStrategy GhcRn)
mb_lds
= case Maybe (LDerivStrategy GhcRn)
mb_lds of
Maybe (LDerivStrategy GhcRn)
Nothing -> Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
-> TcM
(Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)),
[TyVar])
forall ds a. ds -> TcM (ds, [a])
boring_case Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
forall a. Maybe a
Nothing
Just (L SrcAnn NoEpAnns
loc DerivStrategy GhcRn
ds) ->
SrcAnn NoEpAnns
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcAnn NoEpAnns
loc (TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar]))
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
forall a b. (a -> b) -> a -> b
$ do
(DerivStrategy GhcTc
ds', [TyVar]
tvs) <- DerivStrategy GhcRn -> TcM (DerivStrategy GhcTc, [TyVar])
tc_deriv_strategy DerivStrategy GhcRn
ds
(Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)),
[TyVar])
-> TcM
(Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)),
[TyVar])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)
-> Maybe (GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc))
forall a. a -> Maybe a
Just (SrcAnn NoEpAnns
-> DerivStrategy GhcTc
-> GenLocated (SrcAnn NoEpAnns) (DerivStrategy GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
loc DerivStrategy GhcTc
ds'), [TyVar]
tvs)
where
tc_deriv_strategy :: DerivStrategy GhcRn
-> TcM (DerivStrategy GhcTc, [TyVar])
tc_deriv_strategy :: DerivStrategy GhcRn -> TcM (DerivStrategy GhcTc, [TyVar])
tc_deriv_strategy (StockStrategy XStockStrategy GhcRn
_) = DerivStrategy GhcTc -> TcM (DerivStrategy GhcTc, [TyVar])
forall ds a. ds -> TcM (ds, [a])
boring_case (XStockStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XStockStrategy pass -> DerivStrategy pass
StockStrategy XStockStrategy GhcTc
NoExtField
noExtField)
tc_deriv_strategy (AnyclassStrategy XAnyClassStrategy GhcRn
_) = DerivStrategy GhcTc -> TcM (DerivStrategy GhcTc, [TyVar])
forall ds a. ds -> TcM (ds, [a])
boring_case (XAnyClassStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XAnyClassStrategy pass -> DerivStrategy pass
AnyclassStrategy XAnyClassStrategy GhcTc
NoExtField
noExtField)
tc_deriv_strategy (NewtypeStrategy XNewtypeStrategy GhcRn
_) = DerivStrategy GhcTc -> TcM (DerivStrategy GhcTc, [TyVar])
forall ds a. ds -> TcM (ds, [a])
boring_case (XNewtypeStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XNewtypeStrategy pass -> DerivStrategy pass
NewtypeStrategy XNewtypeStrategy GhcTc
NoExtField
noExtField)
tc_deriv_strategy (ViaStrategy XViaStrategy GhcRn
hs_sig)
= do { Type
ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcTopLHsType UserTypeCtxt
DerivClauseCtxt XViaStrategy GhcRn
LHsSigType GhcRn
hs_sig
; rec { ([TyVar]
via_tvs, Type
via_pred) <- SkolemInfoAnon -> Type -> TcM ([TyVar], Type)
tcSkolemiseInvisibleBndrs (Type -> SkolemInfoAnon
DerivSkol Type
via_pred) Type
ty}
; (DerivStrategy GhcTc, [TyVar])
-> TcM (DerivStrategy GhcTc, [TyVar])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XViaStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy XViaStrategy GhcTc
Type
via_pred, [TyVar]
via_tvs) }
boring_case :: ds -> TcM (ds, [a])
boring_case :: forall ds a. ds -> TcM (ds, [a])
boring_case ds
ds = (ds, [a]) -> IOEnv (Env TcGblEnv TcLclEnv) (ds, [a])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ds
ds, [])
tcHsClsInstType :: UserTypeCtxt
-> LHsSigType GhcRn
-> TcM Type
tcHsClsInstType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsClsInstType UserTypeCtxt
user_ctxt LHsSigType GhcRn
hs_inst_ty
= SrcSpan -> TcM Type -> TcM Type
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
hs_inst_ty) (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
do { Type
inst_ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcTopLHsType UserTypeCtxt
user_ctxt LHsSigType GhcRn
hs_inst_ty
; UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM ()
checkValidInstance UserTypeCtxt
user_ctxt LHsSigType GhcRn
hs_inst_ty Type
inst_ty
; Type -> TcM Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
inst_ty }
tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type
tcHsTypeApp :: LHsWcType GhcRn -> Type -> TcM Type
tcHsTypeApp LHsWcType GhcRn
wc_ty Type
kind
| HsWC { hswc_ext :: forall pass thing. HsWildCardBndrs pass thing -> XHsWC pass thing
hswc_ext = XHsWC GhcRn (LHsType GhcRn)
sig_wcs, hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = LHsType GhcRn
hs_ty } <- LHsWcType GhcRn
wc_ty
= do { TcTyMode
mode <- TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode TypeOrKind
TypeLevel HoleMode
HM_VTA
; Type
ty <- LHsType GhcRn -> TcM Type -> TcM Type
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
String -> TcM Type -> TcM Type
forall a. String -> TcM a -> TcM a
solveEqualities String
"tcHsTypeApp" (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
HsQTvsRn -> ([(Name, TyVar)] -> TcM Type) -> TcM Type
forall a. HsQTvsRn -> ([(Name, TyVar)] -> TcM a) -> TcM a
bindNamedWildCardBinders HsQTvsRn
XHsWC GhcRn (LHsType GhcRn)
sig_wcs (([(Name, TyVar)] -> TcM Type) -> TcM Type)
-> ([(Name, TyVar)] -> TcM Type) -> TcM Type
forall a b. (a -> b) -> a -> b
$ \ [(Name, TyVar)]
_ ->
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
hs_ty Type
kind
; Type -> TcM ()
kindGeneralizeNone Type
ty
; Type
ty <- Type -> TcM Type
zonkTcType Type
ty
; UserTypeCtxt -> Type -> TcM ()
checkValidType UserTypeCtxt
TypeAppCtxt Type
ty
; Type -> TcM Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty }
tcFamTyPats :: TyCon
-> HsTyPats GhcRn
-> TcM (TcType, TcKind)
tcFamTyPats :: TyCon -> HsTyPats GhcRn -> TcM (Type, Type)
tcFamTyPats TyCon
fam_tc HsTyPats GhcRn
hs_pats
= do { String -> SDoc -> TcM ()
traceTc String
"tcFamTyPats {" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc, String -> SDoc
text String
"arity:" SDoc -> SDoc -> SDoc
<+> Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
fam_arity ]
; TcTyMode
mode <- TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode TypeOrKind
TypeLevel HoleMode
HM_FamPat
; let fun_ty :: Type
fun_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc []
; (Type
fam_app, Type
res_kind) <- TcTyMode
-> LHsType GhcRn -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
tcInferTyApps TcTyMode
mode LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
lhs_fun Type
fun_ty HsTyPats GhcRn
hs_pats
; Type
res_kind <- Type -> TcM Type
zonkTcType Type
res_kind
; String -> SDoc -> TcM ()
traceTc String
"End tcFamTyPats }" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc, String -> SDoc
text String
"res_kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
res_kind ]
; (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
fam_app, Type
res_kind) }
where
fam_name :: Name
fam_name = TyCon -> Name
tyConName TyCon
fam_tc
fam_arity :: Arity
fam_arity = TyCon -> Arity
tyConArity TyCon
fam_tc
lhs_fun :: GenLocated SrcSpanAnnA (HsType GhcRn)
lhs_fun = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a an. a -> LocatedAn an a
noLocA (XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcRn
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn PromotionFlag
NotPromoted (Name -> GenLocated SrcSpanAnnN Name
forall a an. a -> LocatedAn an a
noLocA Name
fam_name))
tcHsOpenType, tcHsLiftedType,
tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType
tcHsOpenType :: LHsType GhcRn -> TcM Type
tcHsOpenType LHsType GhcRn
hs_ty = LHsType GhcRn -> TcM Type -> TcM Type
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> TcM Type
tcHsOpenTypeNC LHsType GhcRn
hs_ty
tcHsLiftedType :: LHsType GhcRn -> TcM Type
tcHsLiftedType LHsType GhcRn
hs_ty = LHsType GhcRn -> TcM Type -> TcM Type
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> TcM Type
tcHsLiftedTypeNC LHsType GhcRn
hs_ty
tcHsOpenTypeNC :: LHsType GhcRn -> TcM Type
tcHsOpenTypeNC LHsType GhcRn
hs_ty = do { Type
ek <- TcM Type
newOpenTypeKind; LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
ek }
tcHsLiftedTypeNC :: LHsType GhcRn -> TcM Type
tcHsLiftedTypeNC LHsType GhcRn
hs_ty = LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
liftedTypeKind
tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType
tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM Type
tcCheckLHsType LHsType GhcRn
hs_ty ContextKind
exp_kind
= LHsType GhcRn -> TcM Type -> TcM Type
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
do { Type
ek <- ContextKind -> TcM Type
newExpectedKind ContextKind
exp_kind
; LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
ek }
tcInferLHsType :: LHsType GhcRn -> TcM TcType
tcInferLHsType :: LHsType GhcRn -> TcM Type
tcInferLHsType LHsType GhcRn
hs_ty
= do { (Type
ty,Type
_kind) <- LHsType GhcRn -> TcM (Type, Type)
tcInferLHsTypeKind LHsType GhcRn
hs_ty
; Type -> TcM Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty }
tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind)
tcInferLHsTypeKind :: LHsType GhcRn -> TcM (Type, Type)
tcInferLHsTypeKind lhs_ty :: LHsType GhcRn
lhs_ty@(L SrcSpanAnnA
loc HsType GhcRn
hs_ty)
= LHsType GhcRn -> TcM (Type, Type) -> TcM (Type, Type)
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
lhs_ty (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA -> TcM (Type, Type) -> TcM (Type, Type)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
do { (Type
res_ty, Type
res_kind) <- TcTyMode -> HsType GhcRn -> TcM (Type, Type)
tc_infer_hs_type TcTyMode
typeLevelMode HsType GhcRn
hs_ty
; Type -> Type -> TcM (Type, Type)
tcInstInvisibleTyBinders Type
res_ty Type
res_kind }
tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)
tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (Type, Type)
tcInferLHsTypeUnsaturated LHsType GhcRn
hs_ty
= LHsType GhcRn -> TcM (Type, Type) -> TcM (Type, Type)
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
do { TcTyMode
mode <- TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode TypeOrKind
TypeLevel HoleMode
HM_Sig
; case HsType GhcRn -> Maybe (LHsType GhcRn, HsTyPats GhcRn)
splitHsAppTys (GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
forall l e. GenLocated l e -> e
unLoc LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ty) of
Just (LHsType GhcRn
hs_fun_ty, HsTyPats GhcRn
hs_args)
-> do { (Type
fun_ty, Type
_ki) <- TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tcInferTyAppHead TcTyMode
mode LHsType GhcRn
hs_fun_ty
; TcTyMode
-> LHsType GhcRn -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
tcInferTyApps_nosat TcTyMode
mode LHsType GhcRn
hs_fun_ty Type
fun_ty HsTyPats GhcRn
hs_args }
Maybe (LHsType GhcRn, HsTyPats GhcRn)
Nothing -> TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode LHsType GhcRn
hs_ty }
tcMult :: HsArrow GhcRn -> TcM Mult
tcMult :: HsArrow GhcRn -> TcM Type
tcMult HsArrow GhcRn
hc = TcTyMode -> HsArrow GhcRn -> TcM Type
tc_mult TcTyMode
typeLevelMode HsArrow GhcRn
hc
data TcTyMode
= TcTyMode { TcTyMode -> TypeOrKind
mode_tyki :: TypeOrKind
, TcTyMode -> HoleInfo
mode_holes :: HoleInfo }
type HoleInfo = Maybe (TcLevel, HoleMode)
data HoleMode = HM_Sig
| HM_FamPat
| HM_VTA
| HM_TyAppPat
mkMode :: TypeOrKind -> TcTyMode
mkMode :: TypeOrKind -> TcTyMode
mkMode TypeOrKind
tyki = TcTyMode { mode_tyki :: TypeOrKind
mode_tyki = TypeOrKind
tyki, mode_holes :: HoleInfo
mode_holes = HoleInfo
forall a. Maybe a
Nothing }
typeLevelMode, kindLevelMode :: TcTyMode
kindLevelMode :: TcTyMode
kindLevelMode = TypeOrKind -> TcTyMode
mkMode TypeOrKind
KindLevel
typeLevelMode :: TcTyMode
typeLevelMode = TypeOrKind -> TcTyMode
mkMode TypeOrKind
TypeLevel
mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode TypeOrKind
tyki HoleMode
hm
= do { TcLevel
lvl <- TcM TcLevel
getTcLevel
; TcTyMode -> TcM TcTyMode
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyMode { mode_tyki :: TypeOrKind
mode_tyki = TypeOrKind
tyki
, mode_holes :: HoleInfo
mode_holes = (TcLevel, HoleMode) -> HoleInfo
forall a. a -> Maybe a
Just (TcLevel
lvl,HoleMode
hm) }) }
instance Outputable HoleMode where
ppr :: HoleMode -> SDoc
ppr HoleMode
HM_Sig = String -> SDoc
text String
"HM_Sig"
ppr HoleMode
HM_FamPat = String -> SDoc
text String
"HM_FamPat"
ppr HoleMode
HM_VTA = String -> SDoc
text String
"HM_VTA"
ppr HoleMode
HM_TyAppPat = String -> SDoc
text String
"HM_TyAppPat"
instance Outputable TcTyMode where
ppr :: TcTyMode -> SDoc
ppr (TcTyMode { mode_tyki :: TcTyMode -> TypeOrKind
mode_tyki = TypeOrKind
tyki, mode_holes :: TcTyMode -> HoleInfo
mode_holes = HoleInfo
hm })
= String -> SDoc
text String
"TcTyMode" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
sep [ TypeOrKind -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeOrKind
tyki SDoc -> SDoc -> SDoc
<> SDoc
comma
, HoleInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleInfo
hm ])
tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)
tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode (L SrcSpanAnnA
span HsType GhcRn
ty)
= SrcSpanAnnA -> TcM (Type, Type) -> TcM (Type, Type)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
span (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
TcTyMode -> HsType GhcRn -> TcM (Type, Type)
tc_infer_hs_type TcTyMode
mode HsType GhcRn
ty
tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
tc_infer_hs_type_ek :: (() :: Constraint) => TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_infer_hs_type_ek TcTyMode
mode HsType GhcRn
hs_ty Type
ek
= do { (Type
ty, Type
k) <- TcTyMode -> HsType GhcRn -> TcM (Type, Type)
tc_infer_hs_type TcTyMode
mode HsType GhcRn
hs_ty
; (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
hs_ty Type
ty Type
k Type
ek }
tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)
tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (Type, Type)
tc_infer_hs_type TcTyMode
mode (HsParTy XParTy GhcRn
_ LHsType GhcRn
t)
= TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode LHsType GhcRn
t
tc_infer_hs_type TcTyMode
mode HsType GhcRn
ty
| Just (LHsType GhcRn
hs_fun_ty, HsTyPats GhcRn
hs_args) <- HsType GhcRn -> Maybe (LHsType GhcRn, HsTyPats GhcRn)
splitHsAppTys HsType GhcRn
ty
= do { (Type
fun_ty, Type
_ki) <- TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tcInferTyAppHead TcTyMode
mode LHsType GhcRn
hs_fun_ty
; TcTyMode
-> LHsType GhcRn -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
tcInferTyApps TcTyMode
mode LHsType GhcRn
hs_fun_ty Type
fun_ty HsTyPats GhcRn
hs_args }
tc_infer_hs_type TcTyMode
mode (HsKindSig XKindSig GhcRn
_ LHsType GhcRn
ty LHsType GhcRn
sig)
= do { let mode' :: TcTyMode
mode' = TcTyMode
mode { mode_tyki :: TypeOrKind
mode_tyki = TypeOrKind
KindLevel }
; Type
sig' <- TcTyMode -> UserTypeCtxt -> LHsType GhcRn -> TcM Type
tc_lhs_kind_sig TcTyMode
mode' UserTypeCtxt
KindSigCtxt LHsType GhcRn
sig
; String -> SDoc -> TcM ()
traceTc String
"tc_infer_hs_type:sig" (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
ty SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sig')
; Type
ty' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty Type
sig'
; (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty', Type
sig') }
tc_infer_hs_type TcTyMode
mode (HsSpliceTy XSpliceTy GhcRn
_ (HsSpliced XSpliced GhcRn
_ ThModFinalizers
_ (HsSplicedTy HsType GhcRn
ty)))
= TcTyMode -> HsType GhcRn -> TcM (Type, Type)
tc_infer_hs_type TcTyMode
mode HsType GhcRn
ty
tc_infer_hs_type TcTyMode
mode (HsDocTy XDocTy GhcRn
_ LHsType GhcRn
ty LHsDoc GhcRn
_) = TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode LHsType GhcRn
ty
tc_infer_hs_type TcTyMode
_ (XHsType XXType GhcRn
ty)
= do TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
let subst_prs :: [(Unique, TcTyVar)]
subst_prs :: [(Unique, TyVar)]
subst_prs = [ (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
nm, TyVar
tv)
| ATyVar Name
nm TyVar
tv <- NameEnv TcTyThing -> [TcTyThing]
forall a. NameEnv a -> [a]
nonDetNameEnvElts (TcLclEnv -> NameEnv TcTyThing
tcl_env TcLclEnv
env) ]
subst :: TCvSubst
subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst
(TyVarSet -> InScopeSet
mkInScopeSet (TyVarSet -> InScopeSet) -> TyVarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [TyVar] -> TyVarSet
mkVarSet ([TyVar] -> TyVarSet) -> [TyVar] -> TyVarSet
forall a b. (a -> b) -> a -> b
$ ((Unique, TyVar) -> TyVar) -> [(Unique, TyVar)] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map (Unique, TyVar) -> TyVar
forall a b. (a, b) -> b
snd [(Unique, TyVar)]
subst_prs)
([(Unique, Type)] -> TvSubstEnv
forall elt key. [(Unique, elt)] -> UniqFM key elt
listToUFM_Directly ([(Unique, Type)] -> TvSubstEnv) -> [(Unique, Type)] -> TvSubstEnv
forall a b. (a -> b) -> a -> b
$ ((Unique, TyVar) -> (Unique, Type))
-> [(Unique, TyVar)] -> [(Unique, Type)]
forall a b. (a -> b) -> [a] -> [b]
map ((TyVar -> Type) -> (Unique, TyVar) -> (Unique, Type)
forall a b c. (a -> b) -> (c, a) -> (c, b)
liftSnd TyVar -> Type
mkTyVarTy) [(Unique, TyVar)]
subst_prs)
ty' :: Type
ty' = (() :: Constraint) => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst XXType GhcRn
Type
ty
(Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty', (() :: Constraint) => Type -> Type
Type -> Type
tcTypeKind Type
ty')
tc_infer_hs_type TcTyMode
_ (HsExplicitListTy XExplicitListTy GhcRn
_ PromotionFlag
_ [LHsType GhcRn]
tys)
| [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
= (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Type
mkTyConTy TyCon
promotedNilDataCon,
[TyVar] -> Type -> Type
mkSpecForAllTys [TyVar
alphaTyVar] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
mkListTy Type
alphaTy)
tc_infer_hs_type TcTyMode
mode HsType GhcRn
other_ty
= do { Type
kv <- TcM Type
newMetaKindVar
; Type
ty' <- TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_hs_type TcTyMode
mode HsType GhcRn
other_ty Type
kv
; (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty', Type
kv) }
tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType
tcLHsType :: LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
exp_kind
= TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
typeLevelMode LHsType GhcRn
hs_ty Type
exp_kind
tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType
tc_lhs_type :: TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode (L SrcSpanAnnA
span HsType GhcRn
ty) Type
exp_kind
= SrcSpanAnnA -> TcM Type -> TcM Type
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
span (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_hs_type TcTyMode
mode HsType GhcRn
ty Type
exp_kind
tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
tc_hs_type :: TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_hs_type TcTyMode
mode (HsParTy XParTy GhcRn
_ LHsType GhcRn
ty) Type
exp_kind = TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty Type
exp_kind
tc_hs_type TcTyMode
mode (HsDocTy XDocTy GhcRn
_ LHsType GhcRn
ty LHsDoc GhcRn
_) Type
exp_kind = TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty Type
exp_kind
tc_hs_type TcTyMode
_ ty :: HsType GhcRn
ty@(HsBangTy XBangTy GhcRn
_ HsSrcBang
bang LHsType GhcRn
_) Type
_
= do { let bangError :: String -> TcM Type
bangError String
err = TcRnMessage -> TcM Type
forall a. TcRnMessage -> TcM a
failWith (TcRnMessage -> TcM Type) -> TcRnMessage -> TcM Type
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Unexpected" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
err SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"annotation:" SDoc -> SDoc -> SDoc
<+> HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
ty SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
err SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"annotation cannot appear nested inside a type"
; case HsSrcBang
bang of
HsSrcBang SourceText
_ SrcUnpackedness
SrcUnpack SrcStrictness
_ -> String -> TcM Type
bangError String
"UNPACK"
HsSrcBang SourceText
_ SrcUnpackedness
SrcNoUnpack SrcStrictness
_ -> String -> TcM Type
bangError String
"NOUNPACK"
HsSrcBang SourceText
_ SrcUnpackedness
NoSrcUnpack SrcStrictness
SrcLazy -> String -> TcM Type
bangError String
"laziness"
HsSrcBang SourceText
_ SrcUnpackedness
_ SrcStrictness
_ -> String -> TcM Type
bangError String
"strictness" }
tc_hs_type TcTyMode
_ ty :: HsType GhcRn
ty@(HsRecTy {}) Type
_
= TcRnMessage -> TcM Type
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM Type) -> TcRnMessage -> TcM Type
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
(String -> SDoc
text String
"Record syntax is illegal here:" SDoc -> SDoc -> SDoc
<+> HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
ty)
tc_hs_type TcTyMode
mode (HsSpliceTy XSpliceTy GhcRn
_ (HsSpliced XSpliced GhcRn
_ ThModFinalizers
mod_finalizers (HsSplicedTy HsType GhcRn
ty)))
Type
exp_kind
= do ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_hs_type TcTyMode
mode HsType GhcRn
ty Type
exp_kind
tc_hs_type TcTyMode
_ ty :: HsType GhcRn
ty@(HsSpliceTy {}) Type
_exp_kind
= TcRnMessage -> TcM Type
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM Type) -> TcRnMessage -> TcM Type
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
(String -> SDoc
text String
"Unexpected type splice:" SDoc -> SDoc -> SDoc
<+> HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
ty)
tc_hs_type TcTyMode
mode (HsFunTy XFunTy GhcRn
_ HsArrow GhcRn
mult LHsType GhcRn
ty1 LHsType GhcRn
ty2) Type
exp_kind
= TcTyMode
-> HsArrow GhcRn
-> LHsType GhcRn
-> LHsType GhcRn
-> Type
-> TcM Type
tc_fun_type TcTyMode
mode HsArrow GhcRn
mult LHsType GhcRn
ty1 LHsType GhcRn
ty2 Type
exp_kind
tc_hs_type TcTyMode
mode (HsOpTy XOpTy GhcRn
_ PromotionFlag
_ LHsType GhcRn
ty1 (L SrcSpanAnnN
_ Name
op) LHsType GhcRn
ty2) Type
exp_kind
| Name
op Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funTyConKey
= TcTyMode
-> HsArrow GhcRn
-> LHsType GhcRn
-> LHsType GhcRn
-> Type
-> TcM Type
tc_fun_type TcTyMode
mode (LHsUniToken "->" "\8594" GhcRn -> HsArrow GhcRn
forall pass. LHsUniToken "->" "\8594" pass -> HsArrow pass
HsUnrestrictedArrow LHsUniToken "->" "\8594" GhcRn
GenLocated TokenLocation (HsUniToken "->" "\8594")
forall (tok :: Symbol) (utok :: Symbol).
GenLocated TokenLocation (HsUniToken tok utok)
noHsUniTok) LHsType GhcRn
ty1 LHsType GhcRn
ty2 Type
exp_kind
tc_hs_type TcTyMode
mode (HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllTelescope GhcRn
tele, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
ty }) Type
exp_kind
= do { ([TcTyVarBinder]
tv_bndrs, Type
ty') <- TcTyMode
-> HsForAllTelescope GhcRn
-> TcM Type
-> TcM ([TcTyVarBinder], Type)
forall a.
TcTyMode
-> HsForAllTelescope GhcRn -> TcM a -> TcM ([TcTyVarBinder], a)
tcTKTelescope TcTyMode
mode HsForAllTelescope GhcRn
tele (TcM Type -> TcM ([TcTyVarBinder], Type))
-> TcM Type -> TcM ([TcTyVarBinder], Type)
forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty Type
exp_kind
; Type -> TcM Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TcTyVarBinder] -> Type -> Type
mkForAllTys [TcTyVarBinder]
tv_bndrs Type
ty') }
tc_hs_type TcTyMode
mode (HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = LHsContext GhcRn
ctxt, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
rn_ty }) Type
exp_kind
| [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall l e. GenLocated l e -> e
unLoc LHsContext GhcRn
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
ctxt)
= TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
rn_ty Type
exp_kind
| Type -> Bool
tcIsConstraintKind Type
exp_kind
= do { [Type]
ctxt' <- TcTyMode -> LHsContext GhcRn -> TcM [Type]
tc_hs_context TcTyMode
mode LHsContext GhcRn
ctxt
; Type
ty' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
rn_ty Type
constraintKind
; Type -> TcM Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Type -> Type
mkPhiTy [Type]
ctxt' Type
ty') }
| Bool
otherwise
= do { [Type]
ctxt' <- TcTyMode -> LHsContext GhcRn -> TcM [Type]
tc_hs_context TcTyMode
mode LHsContext GhcRn
ctxt
; Type
ek <- TcM Type
newOpenTypeKind
; Type
ty' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
rn_ty Type
ek
; (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
forall l e. GenLocated l e -> e
unLoc LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
rn_ty) ([Type] -> Type -> Type
mkPhiTy [Type]
ctxt' Type
ty')
Type
liftedTypeKind Type
exp_kind }
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsListTy XListTy GhcRn
_ LHsType GhcRn
elt_ty) Type
exp_kind
= do { Type
tau_ty <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
elt_ty Type
liftedTypeKind
; TyCon -> TcM ()
checkWiredInTyCon TyCon
listTyCon
; (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty (Type -> Type
mkListTy Type
tau_ty) Type
liftedTypeKind Type
exp_kind }
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsTupleTy XTupleTy GhcRn
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcRn]
hs_tys) Type
exp_kind
| Just TupleSort
tup_sort <- Type -> Maybe TupleSort
tupKindSort_maybe Type
exp_kind
= String -> SDoc -> TcM ()
traceTc String
"tc_hs_type tuple" ([GenLocated SrcSpanAnnA (HsType GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_tys) TcM () -> TcM Type -> TcM Type
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
HsType GhcRn
-> TcTyMode -> TupleSort -> [LHsType GhcRn] -> Type -> TcM Type
tc_tuple HsType GhcRn
rn_ty TcTyMode
mode TupleSort
tup_sort [LHsType GhcRn]
hs_tys Type
exp_kind
| Bool
otherwise
= do { String -> SDoc -> TcM ()
traceTc String
"tc_hs_type tuple 2" ([GenLocated SrcSpanAnnA (HsType GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_tys)
; ([Type]
tys, [Type]
kinds) <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> TcM (Type, Type))
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) ([Type], [Type])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode) [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_tys
; [Type]
kinds <- (Type -> TcM Type) -> [Type] -> TcM [Type]
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 Type -> TcM Type
zonkTcType [Type]
kinds
; let (Type
arg_kind, TupleSort
tup_sort)
= case [ (Type
k,TupleSort
s) | Type
k <- [Type]
kinds
, Just TupleSort
s <- [Type -> Maybe TupleSort
tupKindSort_maybe Type
k] ] of
((Type
k,TupleSort
s) : [(Type, TupleSort)]
_) -> (Type
k,TupleSort
s)
[] -> (Type
liftedTypeKind, TupleSort
BoxedTuple)
; [Type]
tys' <- [TcM Type] -> TcM [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ SrcSpanAnnA -> TcM Type -> TcM Type
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
(() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
hs_ty Type
ty Type
kind Type
arg_kind
| ((L SrcSpanAnnA
loc HsType GhcRn
hs_ty),Type
ty,Type
kind) <- [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [Type]
-> [Type]
-> [(GenLocated SrcSpanAnnA (HsType GhcRn), Type, Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_tys [Type]
tys [Type]
kinds ]
; HsType GhcRn -> TupleSort -> [Type] -> [Type] -> Type -> TcM Type
finish_tuple HsType GhcRn
rn_ty TupleSort
tup_sort [Type]
tys' ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
forall a b. a -> b -> a
const Type
arg_kind) [Type]
tys') Type
exp_kind }
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsTupleTy XTupleTy GhcRn
_ HsTupleSort
HsUnboxedTuple [LHsType GhcRn]
tys) Type
exp_kind
= HsType GhcRn
-> TcTyMode -> TupleSort -> [LHsType GhcRn] -> Type -> TcM Type
tc_tuple HsType GhcRn
rn_ty TcTyMode
mode TupleSort
UnboxedTuple [LHsType GhcRn]
tys Type
exp_kind
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsSumTy XSumTy GhcRn
_ [LHsType GhcRn]
hs_tys) Type
exp_kind
= do { let arity :: Arity
arity = [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_tys
; [Type]
arg_kinds <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> TcM Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> TcM [Type]
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 (\GenLocated SrcSpanAnnA (HsType GhcRn)
_ -> TcM Type
newOpenTypeKind) [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_tys
; [Type]
tau_tys <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> Type -> TcM Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> [Type] -> TcM [Type]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode) [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_tys [Type]
arg_kinds
; let arg_reps :: [Type]
arg_reps = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (() :: Constraint) => Type -> Type
Type -> Type
kindRep [Type]
arg_kinds
arg_tys :: [Type]
arg_tys = [Type]
arg_reps [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
tau_tys
sum_ty :: Type
sum_ty = TyCon -> [Type] -> Type
mkTyConApp (Arity -> TyCon
sumTyCon Arity
arity) [Type]
arg_tys
sum_kind :: Type
sum_kind = [Type] -> Type
unboxedSumKind [Type]
arg_reps
; (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty Type
sum_ty Type
sum_kind Type
exp_kind
}
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsExplicitListTy XExplicitListTy GhcRn
_ PromotionFlag
_ [LHsType GhcRn]
tys) Type
exp_kind
= do { [(Type, Type)]
tks <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> TcM (Type, Type))
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, Type)]
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 (TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode) [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
; ([Type]
taus', Type
kind) <- [LHsType GhcRn] -> [(Type, Type)] -> TcM ([Type], Type)
unifyKinds [LHsType GhcRn]
tys [(Type, Type)]
tks
; let ty :: Type
ty = ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type -> Type
mk_cons Type
kind) (Type -> Type
mk_nil Type
kind) [Type]
taus')
; (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty Type
ty (Type -> Type
mkListTy Type
kind) Type
exp_kind }
where
mk_cons :: Type -> Type -> Type -> Type
mk_cons Type
k Type
a Type
b = TyCon -> [Type] -> Type
mkTyConApp (DataCon -> TyCon
promoteDataCon DataCon
consDataCon) [Type
k, Type
a, Type
b]
mk_nil :: Type -> Type
mk_nil Type
k = TyCon -> [Type] -> Type
mkTyConApp (DataCon -> TyCon
promoteDataCon DataCon
nilDataCon) [Type
k]
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsExplicitTupleTy XExplicitTupleTy GhcRn
_ [LHsType GhcRn]
tys) Type
exp_kind
= do { [Type]
ks <- Arity -> TcM Type -> TcM [Type]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
arity TcM Type
newMetaKindVar
; [Type]
taus <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> Type -> TcM Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> [Type] -> TcM [Type]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode) [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys [Type]
ks
; let kind_con :: TyCon
kind_con = Boxity -> Arity -> TyCon
tupleTyCon Boxity
Boxed Arity
arity
ty_con :: TyCon
ty_con = Boxity -> Arity -> TyCon
promotedTupleDataCon Boxity
Boxed Arity
arity
tup_k :: Type
tup_k = TyCon -> [Type] -> Type
mkTyConApp TyCon
kind_con [Type]
ks
; Arity -> TcM ()
checkTupSize Arity
arity
; (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty (TyCon -> [Type] -> Type
mkTyConApp TyCon
ty_con ([Type]
ks [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
taus)) Type
tup_k Type
exp_kind }
where
arity :: Arity
arity = [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsIParamTy XIParamTy GhcRn
_ (L SrcAnn NoEpAnns
_ HsIPName
n) LHsType GhcRn
ty) Type
exp_kind
= do { Bool -> TcM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (TypeOrKind -> Bool
isTypeLevel (TcTyMode -> TypeOrKind
mode_tyki TcTyMode
mode))
; Type
ty' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty Type
liftedTypeKind
; let n' :: Type
n' = FastString -> Type
mkStrLitTy (FastString -> Type) -> FastString -> Type
forall a b. (a -> b) -> a -> b
$ HsIPName -> FastString
hsIPNameFS HsIPName
n
; Class
ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
; (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty (Class -> [Type] -> Type
mkClassPred Class
ipClass [Type
n',Type
ty'])
Type
constraintKind Type
exp_kind }
tc_hs_type TcTyMode
_ rn_ty :: HsType GhcRn
rn_ty@(HsStarTy XStarTy GhcRn
_ Bool
_) Type
exp_kind
= (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty Type
liftedTypeKind Type
liftedTypeKind Type
exp_kind
tc_hs_type TcTyMode
_ rn_ty :: HsType GhcRn
rn_ty@(HsTyLit XTyLit GhcRn
_ (HsNumTy SourceText
_ Integer
n)) Type
exp_kind
= do { TyCon -> TcM ()
checkWiredInTyCon TyCon
naturalTyCon
; (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty (Integer -> Type
mkNumLitTy Integer
n) Type
naturalTy Type
exp_kind }
tc_hs_type TcTyMode
_ rn_ty :: HsType GhcRn
rn_ty@(HsTyLit XTyLit GhcRn
_ (HsStrTy SourceText
_ FastString
s)) Type
exp_kind
= do { TyCon -> TcM ()
checkWiredInTyCon TyCon
typeSymbolKindCon
; (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty (FastString -> Type
mkStrLitTy FastString
s) Type
typeSymbolKind Type
exp_kind }
tc_hs_type TcTyMode
_ rn_ty :: HsType GhcRn
rn_ty@(HsTyLit XTyLit GhcRn
_ (HsCharTy SourceText
_ Char
c)) Type
exp_kind
= do { TyCon -> TcM ()
checkWiredInTyCon TyCon
charTyCon
; (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty (Char -> Type
mkCharLitTy Char
c) Type
charTy Type
exp_kind }
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(HsWildCardTy XWildCardTy GhcRn
_) Type
ek
= IsExtraConstraint -> TcTyMode -> HsType GhcRn -> Type -> TcM Type
tcAnonWildCardOcc IsExtraConstraint
NoExtraConstraint TcTyMode
mode HsType GhcRn
ty Type
ek
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(HsTyVar {}) Type
ek = (() :: Constraint) => TcTyMode -> HsType GhcRn -> Type -> TcM Type
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_infer_hs_type_ek TcTyMode
mode HsType GhcRn
ty Type
ek
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(HsAppTy {}) Type
ek = (() :: Constraint) => TcTyMode -> HsType GhcRn -> Type -> TcM Type
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_infer_hs_type_ek TcTyMode
mode HsType GhcRn
ty Type
ek
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(HsAppKindTy{}) Type
ek = (() :: Constraint) => TcTyMode -> HsType GhcRn -> Type -> TcM Type
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_infer_hs_type_ek TcTyMode
mode HsType GhcRn
ty Type
ek
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(HsOpTy {}) Type
ek = (() :: Constraint) => TcTyMode -> HsType GhcRn -> Type -> TcM Type
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_infer_hs_type_ek TcTyMode
mode HsType GhcRn
ty Type
ek
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(HsKindSig {}) Type
ek = (() :: Constraint) => TcTyMode -> HsType GhcRn -> Type -> TcM Type
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_infer_hs_type_ek TcTyMode
mode HsType GhcRn
ty Type
ek
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(XHsType {}) Type
ek = (() :: Constraint) => TcTyMode -> HsType GhcRn -> Type -> TcM Type
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_infer_hs_type_ek TcTyMode
mode HsType GhcRn
ty Type
ek
tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult
tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Type
tc_mult TcTyMode
mode HsArrow GhcRn
ty = TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode (HsArrow GhcRn -> LHsType GhcRn
arrowToHsType HsArrow GhcRn
ty) Type
multiplicityTy
tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind
-> TcM TcType
tc_fun_type :: TcTyMode
-> HsArrow GhcRn
-> LHsType GhcRn
-> LHsType GhcRn
-> Type
-> TcM Type
tc_fun_type TcTyMode
mode HsArrow GhcRn
mult LHsType GhcRn
ty1 LHsType GhcRn
ty2 Type
exp_kind = case TcTyMode -> TypeOrKind
mode_tyki TcTyMode
mode of
TypeOrKind
TypeLevel ->
do { Type
arg_k <- TcM Type
newOpenTypeKind
; Type
res_k <- TcM Type
newOpenTypeKind
; Type
ty1' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty1 Type
arg_k
; Type
ty2' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty2 Type
res_k
; Type
mult' <- TcTyMode -> HsArrow GhcRn -> TcM Type
tc_mult TcTyMode
mode HsArrow GhcRn
mult
; (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (XFunTy GhcRn
-> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcRn
EpAnn NoEpAnns
forall a. EpAnn a
noAnn HsArrow GhcRn
mult LHsType GhcRn
ty1 LHsType GhcRn
ty2) (Type -> Type -> Type -> Type
mkVisFunTy Type
mult' Type
ty1' Type
ty2')
Type
liftedTypeKind Type
exp_kind }
TypeOrKind
KindLevel ->
do { Type
ty1' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty1 Type
liftedTypeKind
; Type
ty2' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty2 Type
liftedTypeKind
; Type
mult' <- TcTyMode -> HsArrow GhcRn -> TcM Type
tc_mult TcTyMode
mode HsArrow GhcRn
mult
; (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (XFunTy GhcRn
-> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcRn
EpAnn NoEpAnns
forall a. EpAnn a
noAnn HsArrow GhcRn
mult LHsType GhcRn
ty1 LHsType GhcRn
ty2) (Type -> Type -> Type -> Type
mkVisFunTy Type
mult' Type
ty1' Type
ty2')
Type
liftedTypeKind Type
exp_kind }
tupKindSort_maybe :: TcKind -> Maybe TupleSort
tupKindSort_maybe :: Type -> Maybe TupleSort
tupKindSort_maybe Type
k
| Just (Type
k', Coercion
_) <- Type -> Maybe (Type, Coercion)
splitCastTy_maybe Type
k = Type -> Maybe TupleSort
tupKindSort_maybe Type
k'
| Just Type
k' <- Type -> Maybe Type
tcView Type
k = Type -> Maybe TupleSort
tupKindSort_maybe Type
k'
| Type -> Bool
tcIsConstraintKind Type
k = TupleSort -> Maybe TupleSort
forall a. a -> Maybe a
Just TupleSort
ConstraintTuple
| Type -> Bool
tcIsLiftedTypeKind Type
k = TupleSort -> Maybe TupleSort
forall a. a -> Maybe a
Just TupleSort
BoxedTuple
| Bool
otherwise = Maybe TupleSort
forall a. Maybe a
Nothing
tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType
tc_tuple :: HsType GhcRn
-> TcTyMode -> TupleSort -> [LHsType GhcRn] -> Type -> TcM Type
tc_tuple HsType GhcRn
rn_ty TcTyMode
mode TupleSort
tup_sort [LHsType GhcRn]
tys Type
exp_kind
= do { [Type]
arg_kinds <- case TupleSort
tup_sort of
TupleSort
BoxedTuple -> [Type] -> TcM [Type]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Arity -> Type -> [Type]
forall a. Arity -> a -> [a]
replicate Arity
arity Type
liftedTypeKind)
TupleSort
UnboxedTuple -> Arity -> TcM Type -> TcM [Type]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
arity TcM Type
newOpenTypeKind
TupleSort
ConstraintTuple -> [Type] -> TcM [Type]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Arity -> Type -> [Type]
forall a. Arity -> a -> [a]
replicate Arity
arity Type
constraintKind)
; [Type]
tau_tys <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> Type -> TcM Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> [Type] -> TcM [Type]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode) [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys [Type]
arg_kinds
; HsType GhcRn -> TupleSort -> [Type] -> [Type] -> Type -> TcM Type
finish_tuple HsType GhcRn
rn_ty TupleSort
tup_sort [Type]
tau_tys [Type]
arg_kinds Type
exp_kind }
where
arity :: Arity
arity = [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [LHsType GhcRn]
[GenLocated SrcSpanAnnA (HsType GhcRn)]
tys
finish_tuple :: HsType GhcRn
-> TupleSort
-> [TcType]
-> [TcKind]
-> TcKind
-> TcM TcType
finish_tuple :: HsType GhcRn -> TupleSort -> [Type] -> [Type] -> Type -> TcM Type
finish_tuple HsType GhcRn
rn_ty TupleSort
tup_sort [Type]
tau_tys [Type]
tau_kinds Type
exp_kind = do
String -> SDoc -> TcM ()
traceTc String
"finish_tuple" (TupleSort -> SDoc
forall a. Outputable a => a -> SDoc
ppr TupleSort
tup_sort SDoc -> SDoc -> SDoc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tau_kinds SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp_kind)
case TupleSort
tup_sort of
TupleSort
ConstraintTuple
| [Type
tau_ty] <- [Type]
tau_tys
-> Type -> Type -> TcM Type
check_expected_kind Type
tau_ty Type
constraintKind
| Bool
otherwise
-> do let tycon :: TyCon
tycon = Arity -> TyCon
cTupleTyCon Arity
arity
Arity -> TcM ()
checkCTupSize Arity
arity
Type -> Type -> TcM Type
check_expected_kind (TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type]
tau_tys) Type
constraintKind
TupleSort
BoxedTuple -> do
let tycon :: TyCon
tycon = Boxity -> Arity -> TyCon
tupleTyCon Boxity
Boxed Arity
arity
Arity -> TcM ()
checkTupSize Arity
arity
TyCon -> TcM ()
checkWiredInTyCon TyCon
tycon
Type -> Type -> TcM Type
check_expected_kind (TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type]
tau_tys) Type
liftedTypeKind
TupleSort
UnboxedTuple -> do
let tycon :: TyCon
tycon = Boxity -> Arity -> TyCon
tupleTyCon Boxity
Unboxed Arity
arity
tau_reps :: [Type]
tau_reps = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (() :: Constraint) => Type -> Type
Type -> Type
kindRep [Type]
tau_kinds
arg_tys :: [Type]
arg_tys = [Type]
tau_reps [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
tau_tys
res_kind :: Type
res_kind = [Type] -> Type
unboxedTupleKind [Type]
tau_reps
Arity -> TcM ()
checkTupSize Arity
arity
Type -> Type -> TcM Type
check_expected_kind (TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type]
arg_tys) Type
res_kind
where
arity :: Arity
arity = [Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
tau_tys
check_expected_kind :: Type -> Type -> TcM Type
check_expected_kind Type
ty Type
act_kind =
(() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty Type
ty Type
act_kind Type
exp_kind
splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])
splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, HsTyPats GhcRn)
splitHsAppTys HsType GhcRn
hs_ty
| HsType GhcRn -> Bool
is_app HsType GhcRn
hs_ty = (GenLocated SrcSpanAnnA (HsType GhcRn),
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))])
-> Maybe
(GenLocated SrcSpanAnnA (HsType GhcRn),
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))])
forall a. a -> Maybe a
Just (LHsType GhcRn -> HsTyPats GhcRn -> (LHsType GhcRn, HsTyPats GhcRn)
go (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a an. a -> LocatedAn an a
noLocA HsType GhcRn
hs_ty) [])
| Bool
otherwise = Maybe (LHsType GhcRn, HsTyPats GhcRn)
Maybe
(GenLocated SrcSpanAnnA (HsType GhcRn),
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))])
forall a. Maybe a
Nothing
where
is_app :: HsType GhcRn -> Bool
is_app :: HsType GhcRn -> Bool
is_app (HsAppKindTy {}) = Bool
True
is_app (HsAppTy {}) = Bool
True
is_app (HsOpTy XOpTy GhcRn
_ PromotionFlag
_ LHsType GhcRn
_ (L SrcSpanAnnN
_ Name
op) LHsType GhcRn
_) = Bool -> Bool
not (Name
op Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funTyConKey)
is_app (HsTyVar {}) = Bool
True
is_app (HsParTy XParTy GhcRn
_ (L SrcSpanAnnA
_ HsType GhcRn
ty)) = HsType GhcRn -> Bool
is_app HsType GhcRn
ty
is_app HsType GhcRn
_ = Bool
False
go :: LHsType GhcRn
-> [HsArg (LHsType GhcRn) (LHsKind GhcRn)]
-> (LHsType GhcRn,
[HsArg (LHsType GhcRn) (LHsKind GhcRn)])
go :: LHsType GhcRn -> HsTyPats GhcRn -> (LHsType GhcRn, HsTyPats GhcRn)
go (L SrcSpanAnnA
_ (HsAppTy XAppTy GhcRn
_ LHsType GhcRn
f LHsType GhcRn
a)) HsTyPats GhcRn
as = LHsType GhcRn -> HsTyPats GhcRn -> (LHsType GhcRn, HsTyPats GhcRn)
go LHsType GhcRn
f (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
a HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a. a -> [a] -> [a]
: HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
as)
go (L SrcSpanAnnA
_ (HsAppKindTy XAppKindTy GhcRn
l LHsType GhcRn
ty LHsType GhcRn
k)) HsTyPats GhcRn
as = LHsType GhcRn -> HsTyPats GhcRn -> (LHsType GhcRn, HsTyPats GhcRn)
go LHsType GhcRn
ty (SrcSpan
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg XAppKindTy GhcRn
SrcSpan
l LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
k HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a. a -> [a] -> [a]
: HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
as)
go (L SrcSpanAnnA
sp (HsParTy XParTy GhcRn
_ LHsType GhcRn
f)) HsTyPats GhcRn
as = LHsType GhcRn -> HsTyPats GhcRn -> (LHsType GhcRn, HsTyPats GhcRn)
go LHsType GhcRn
f (SrcSpan
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
sp) HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a. a -> [a] -> [a]
: HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
as)
go (L SrcSpanAnnA
_ (HsOpTy XOpTy GhcRn
_ PromotionFlag
prom LHsType GhcRn
l op :: LIdP GhcRn
op@(L SrcSpanAnnN
sp Name
_) LHsType GhcRn
r)) HsTyPats GhcRn
as
= ( SrcSpanAnnA
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la SrcSpanAnnN
sp) (XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcRn
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn PromotionFlag
prom LIdP GhcRn
op)
, GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
l HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a. a -> [a] -> [a]
: GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
r HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a. a -> [a] -> [a]
: HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
as )
go LHsType GhcRn
f HsTyPats GhcRn
as = (LHsType GhcRn
f, HsTyPats GhcRn
as)
tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)
tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tcInferTyAppHead TcTyMode
_ (L SrcSpanAnnA
_ (HsTyVar XTyVar GhcRn
_ PromotionFlag
_ (L SrcSpanAnnN
_ Name
tv)))
= Name -> TcM (Type, Type)
tcTyVar Name
tv
tcInferTyAppHead TcTyMode
mode LHsType GhcRn
ty
= TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode LHsType GhcRn
ty
tcInferTyApps, tcInferTyApps_nosat
:: TcTyMode
-> LHsType GhcRn
-> TcType
-> [LHsTypeArg GhcRn]
-> TcM (TcType, TcKind)
tcInferTyApps :: TcTyMode
-> LHsType GhcRn -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
tcInferTyApps TcTyMode
mode LHsType GhcRn
hs_ty Type
fun HsTyPats GhcRn
hs_args
= do { (Type
f_args, Type
res_k) <- TcTyMode
-> LHsType GhcRn -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
tcInferTyApps_nosat TcTyMode
mode LHsType GhcRn
hs_ty Type
fun HsTyPats GhcRn
hs_args
; Type -> Type -> TcM (Type, Type)
saturateFamApp Type
f_args Type
res_k }
tcInferTyApps_nosat :: TcTyMode
-> LHsType GhcRn -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
tcInferTyApps_nosat TcTyMode
mode LHsType GhcRn
orig_hs_ty Type
fun HsTyPats GhcRn
orig_hs_args
= do { String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps {" (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
orig_hs_ty SDoc -> SDoc -> SDoc
$$ [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
orig_hs_args)
; (Type
f_args, Type
res_k) <- Arity
-> Type
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcM (Type, Type)
go_init Arity
1 Type
fun HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
orig_hs_args
; String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps }" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
f_args SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
res_k)
; (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
f_args, Type
res_k) }
where
go_init :: Arity
-> Type
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcM (Type, Type)
go_init Arity
n Type
fun [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
all_args
= Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n Type
fun TCvSubst
empty_subst Type
fun_ki HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
all_args
where
fun_ki :: Type
fun_ki = (() :: Constraint) => Type -> Type
Type -> Type
tcTypeKind Type
fun
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (InScopeSet -> TCvSubst) -> InScopeSet -> TCvSubst
forall a b. (a -> b) -> a -> b
$ TyVarSet -> InScopeSet
mkInScopeSet (TyVarSet -> InScopeSet) -> TyVarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$
Type -> TyVarSet
tyCoVarsOfType Type
fun_ki
go :: Int
-> TcType
-> TCvSubst
-> TcKind
-> [LHsTypeArg GhcRn]
-> TcM (TcType, TcKind)
go :: Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n Type
fun TCvSubst
subst Type
fun_ki HsTyPats GhcRn
all_args = case (HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
all_args, Type -> Maybe (TyCoBinder, Type)
tcSplitPiTy_maybe Type
fun_ki) of
([], Maybe (TyCoBinder, Type)
_) -> (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
fun, (() :: Constraint) => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
fun_ki)
(HsArgPar SrcSpan
_ : [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
args, Maybe (TyCoBinder, Type)
_) -> Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n Type
fun TCvSubst
subst Type
fun_ki HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
args
(HsTypeArg SrcSpan
_ GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ki_arg : [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
hs_args, Just (TyCoBinder
ki_binder, Type
inner_ki)) ->
case TyCoBinder
ki_binder of
Named (Bndr TyVar
_ ArgFlag
Inferred) -> TyCoBinder -> Type -> TcM (Type, Type)
instantiate TyCoBinder
ki_binder Type
inner_ki
Anon AnonArgFlag
InvisArg Scaled Type
_ -> TyCoBinder -> Type -> TcM (Type, Type)
instantiate TyCoBinder
ki_binder Type
inner_ki
Named (Bndr TyVar
_ ArgFlag
Specified) ->
do { String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (vis kind app)"
([SDoc] -> SDoc
vcat [ TyCoBinder -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoBinder
ki_binder, GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ki_arg
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCoBinder -> Type
tyBinderType TyCoBinder
ki_binder)
, TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst ])
; let exp_kind :: Type
exp_kind = (() :: Constraint) => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ TyCoBinder -> Type
tyBinderType TyCoBinder
ki_binder
; TcTyMode
arg_mode <- TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode TypeOrKind
KindLevel HoleMode
HM_VTA
; Type
ki_arg <- SDoc -> TcM Type -> TcM Type
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn) -> Arity -> SDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Arity -> SDoc
funAppCtxt LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
orig_hs_ty GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ki_arg Arity
n) (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
arg_mode LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ki_arg Type
exp_kind
; String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (vis kind app)" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp_kind)
; (TCvSubst
subst', Type
fun') <- TCvSubst -> Type -> TyCoBinder -> Type -> TcM (TCvSubst, Type)
mkAppTyM TCvSubst
subst Type
fun TyCoBinder
ki_binder Type
ki_arg
; Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) Type
fun' TCvSubst
subst' Type
inner_ki HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
hs_args }
TyCoBinder
_ -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Type -> TcM (Type, Type)
forall {a} {a} {a}.
(Outputable a, Outputable a) =>
a -> a -> TcRn a
ty_app_err GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ki_arg (Type -> TcM (Type, Type)) -> Type -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$ (() :: Constraint) => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
fun_ki
(HsTypeArg SrcSpan
_ GenLocated SrcSpanAnnA (HsType GhcRn)
ki_arg : [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
_, Maybe (TyCoBinder, Type)
Nothing) -> TcM (Type, Type) -> TcM (Type, Type)
try_again_after_substing_or (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
GenLocated SrcSpanAnnA (HsType GhcRn) -> Type -> TcM (Type, Type)
forall {a} {a} {a}.
(Outputable a, Outputable a) =>
a -> a -> TcRn a
ty_app_err GenLocated SrcSpanAnnA (HsType GhcRn)
ki_arg Type
substed_fun_ki
(HsValArg GenLocated SrcSpanAnnA (HsType GhcRn)
arg : [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
args, Just (TyCoBinder
ki_binder, Type
inner_ki))
| TyCoBinder -> Bool
isInvisibleBinder TyCoBinder
ki_binder
-> TyCoBinder -> Type -> TcM (Type, Type)
instantiate TyCoBinder
ki_binder Type
inner_ki
| Bool
otherwise
-> do { String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (vis normal app)"
([SDoc] -> SDoc
vcat [ TyCoBinder -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoBinder
ki_binder
, GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
arg
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCoBinder -> Type
tyBinderType TyCoBinder
ki_binder)
, TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst ])
; let exp_kind :: Type
exp_kind = (() :: Constraint) => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ TyCoBinder -> Type
tyBinderType TyCoBinder
ki_binder
; Type
arg' <- SDoc -> TcM Type -> TcM Type
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn) -> Arity -> SDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Arity -> SDoc
funAppCtxt LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
orig_hs_ty GenLocated SrcSpanAnnA (HsType GhcRn)
arg Arity
n) (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
arg Type
exp_kind
; String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (vis normal app) 2" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp_kind)
; (TCvSubst
subst', Type
fun') <- TCvSubst -> Type -> TyCoBinder -> Type -> TcM (TCvSubst, Type)
mkAppTyM TCvSubst
subst Type
fun TyCoBinder
ki_binder Type
arg'
; Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) Type
fun' TCvSubst
subst' Type
inner_ki HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
args }
(HsValArg GenLocated SrcSpanAnnA (HsType GhcRn)
_ : [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
_, Maybe (TyCoBinder, Type)
Nothing)
-> TcM (Type, Type) -> TcM (Type, Type)
try_again_after_substing_or (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
do { let arrows_needed :: Arity
arrows_needed = [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> Arity
forall tm ty. [HsArg tm ty] -> Arity
n_initial_val_args HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
all_args
; Coercion
co <- TypedThing -> Arity -> Type -> TcM Coercion
matchExpectedFunKind (HsType GhcRn -> TypedThing
HsTypeRnThing (HsType GhcRn -> TypedThing) -> HsType GhcRn -> TypedThing
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
forall l e. GenLocated l e -> e
unLoc LHsType GhcRn
GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ty) Arity
arrows_needed Type
substed_fun_ki
; Type
fun' <- Type -> TcM Type
zonkTcType (Type
fun Type -> Coercion -> Type
`mkTcCastTy` Coercion
co)
; String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (no binder)" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun_ki
, Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
arrows_needed
, Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun' SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((() :: Constraint) => Type -> Type
Type -> Type
tcTypeKind Type
fun')]
; Arity
-> Type
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcM (Type, Type)
go_init Arity
n Type
fun' HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
all_args }
where
instantiate :: TyCoBinder -> Type -> TcM (Type, Type)
instantiate TyCoBinder
ki_binder Type
inner_ki
= do { String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (need to instantiate)"
([SDoc] -> SDoc
vcat [ TyCoBinder -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCoBinder
ki_binder, TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst])
; (TCvSubst
subst', Type
arg') <- TCvSubst -> TyCoBinder -> TcM (TCvSubst, Type)
tcInstInvisibleTyBinder TCvSubst
subst TyCoBinder
ki_binder
; Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n (Type -> Type -> Type
mkAppTy Type
fun Type
arg') TCvSubst
subst' Type
inner_ki HsTyPats GhcRn
all_args }
try_again_after_substing_or :: TcM (Type, Type) -> TcM (Type, Type)
try_again_after_substing_or TcM (Type, Type)
fallthrough
| Bool -> Bool
not (TCvSubst -> Bool
isEmptyTCvSubst TCvSubst
subst)
= Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n Type
fun TCvSubst
zapped_subst Type
substed_fun_ki HsTyPats GhcRn
all_args
| Bool
otherwise
= TcM (Type, Type)
fallthrough
zapped_subst :: TCvSubst
zapped_subst = TCvSubst -> TCvSubst
zapTCvSubst TCvSubst
subst
substed_fun_ki :: Type
substed_fun_ki = (() :: Constraint) => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
fun_ki
hs_ty :: LHsType GhcRn
hs_ty = LHsType GhcRn -> HsTyPats GhcRn -> LHsType GhcRn
appTypeToArg LHsType GhcRn
orig_hs_ty (Arity
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a. Arity -> [a] -> [a]
take (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1) HsTyPats GhcRn
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
orig_hs_args)
n_initial_val_args :: [HsArg tm ty] -> Arity
n_initial_val_args :: forall tm ty. [HsArg tm ty] -> Arity
n_initial_val_args (HsValArg {} : [HsArg tm ty]
args) = Arity
1 Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ [HsArg tm ty] -> Arity
forall tm ty. [HsArg tm ty] -> Arity
n_initial_val_args [HsArg tm ty]
args
n_initial_val_args (HsArgPar {} : [HsArg tm ty]
args) = [HsArg tm ty] -> Arity
forall tm ty. [HsArg tm ty] -> Arity
n_initial_val_args [HsArg tm ty]
args
n_initial_val_args [HsArg tm ty]
_ = Arity
0
ty_app_err :: a -> a -> TcRn a
ty_app_err a
arg a
ty
= TcRnMessage -> TcRn a
forall a. TcRnMessage -> TcM a
failWith (TcRnMessage -> TcRn a) -> TcRnMessage -> TcRn a
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Cannot apply function of kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
ty)
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"to visible kind argument" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
arg)
mkAppTyM :: TCvSubst
-> TcType -> TyCoBinder
-> TcType
-> TcM (TCvSubst, TcType)
mkAppTyM :: TCvSubst -> Type -> TyCoBinder -> Type -> TcM (TCvSubst, Type)
mkAppTyM TCvSubst
subst Type
fun TyCoBinder
ki_binder Type
arg
|
TyConApp TyCon
tc [Type]
args <- Type
fun
, TyCon -> Bool
isTypeSynonymTyCon TyCon
tc
, [Type]
args [Type] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthIs` (TyCon -> Arity
tyConArity TyCon
tc Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
1)
, (TyVar -> Bool) -> [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TyVar -> Bool
isTrickyTvBinder (TyCon -> [TyVar]
tyConTyVars TyCon
tc)
= do { Type
arg' <- Type -> TcM Type
zonkTcType Type
arg
; [Type]
args' <- [Type] -> TcM [Type]
zonkTcTypes [Type]
args
; let subst' :: TCvSubst
subst' = case TyCoBinder
ki_binder of
Anon {} -> TCvSubst
subst
Named (Bndr TyVar
tv ArgFlag
_) -> TCvSubst -> TyVar -> Type -> TCvSubst
extendTvSubstAndInScope TCvSubst
subst TyVar
tv Type
arg'
; (TCvSubst, Type) -> TcM (TCvSubst, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst', TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ([Type]
args' [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
arg'])) }
mkAppTyM TCvSubst
subst Type
fun (Anon {}) Type
arg
= (TCvSubst, Type) -> TcM (TCvSubst, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst, Type -> Type -> Type
mk_app_ty Type
fun Type
arg)
mkAppTyM TCvSubst
subst Type
fun (Named (Bndr TyVar
tv ArgFlag
_)) Type
arg
= do { Type
arg' <- if TyVar -> Bool
isTrickyTvBinder TyVar
tv
then
Type -> TcM Type
zonkTcType Type
arg
else Type -> TcM Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
arg
; (TCvSubst, Type) -> TcM (TCvSubst, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( TCvSubst -> TyVar -> Type -> TCvSubst
extendTvSubstAndInScope TCvSubst
subst TyVar
tv Type
arg'
, Type -> Type -> Type
mk_app_ty Type
fun Type
arg' ) }
mk_app_ty :: TcType -> TcType -> TcType
mk_app_ty :: Type -> Type -> Type
mk_app_ty Type
fun Type
arg
= Bool -> SDoc -> Type -> Type
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Type -> Bool
isPiTy Type
fun_kind)
(Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun_kind SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
arg) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
mkAppTy Type
fun Type
arg
where
fun_kind :: Type
fun_kind = (() :: Constraint) => Type -> Type
Type -> Type
tcTypeKind Type
fun
isTrickyTvBinder :: TcTyVar -> Bool
isTrickyTvBinder :: TyVar -> Bool
isTrickyTvBinder TyVar
tv = Type -> Bool
isPiTy (TyVar -> Type
tyVarKind TyVar
tv)
saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind)
saturateFamApp :: Type -> Type -> TcM (Type, Type)
saturateFamApp Type
ty Type
kind
| Just (TyCon
tc, [Type]
args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
, TyCon -> Bool
mustBeSaturated TyCon
tc
, let n_to_inst :: Arity
n_to_inst = TyCon -> Arity
tyConArity TyCon
tc Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- [Type] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
args
= do { ([Type]
extra_args, Type
ki') <- Arity -> Type -> TcM ([Type], Type)
tcInstInvisibleTyBindersN Arity
n_to_inst Type
kind
; (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty Type -> [Type] -> Type
`mkTcAppTys` [Type]
extra_args, Type
ki') }
| Bool
otherwise
= (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty, Type
kind)
appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn
appTypeToArg :: LHsType GhcRn -> HsTyPats GhcRn -> LHsType GhcRn
appTypeToArg LHsType GhcRn
f [] = LHsType GhcRn
f
appTypeToArg LHsType GhcRn
f (HsValArg LHsType GhcRn
arg : HsTyPats GhcRn
args) = LHsType GhcRn -> HsTyPats GhcRn -> LHsType GhcRn
appTypeToArg (LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
mkHsAppTy LHsType GhcRn
f LHsType GhcRn
arg) HsTyPats GhcRn
args
appTypeToArg LHsType GhcRn
f (HsArgPar SrcSpan
_ : HsTyPats GhcRn
args) = LHsType GhcRn -> HsTyPats GhcRn -> LHsType GhcRn
appTypeToArg LHsType GhcRn
f HsTyPats GhcRn
args
appTypeToArg LHsType GhcRn
f (HsTypeArg SrcSpan
l LHsType GhcRn
arg : HsTyPats GhcRn
args)
= LHsType GhcRn -> HsTyPats GhcRn -> LHsType GhcRn
appTypeToArg (XAppKindTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
forall (p :: Pass).
XAppKindTy (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
mkHsAppKindTy XAppKindTy GhcRn
SrcSpan
l LHsType GhcRn
f LHsType GhcRn
arg) HsTyPats GhcRn
args
checkExpectedKind :: HasDebugCallStack
=> HsType GhcRn
-> TcType
-> TcKind
-> TcKind
-> TcM TcType
checkExpectedKind :: (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
hs_ty Type
ty Type
act_kind Type
exp_kind
= do { String -> SDoc -> TcM ()
traceTc String
"checkExpectedKind" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act_kind)
; ([Type]
new_args, Type
act_kind') <- Arity -> Type -> TcM ([Type], Type)
tcInstInvisibleTyBindersN Arity
n_to_inst Type
act_kind
; let origin :: CtOrigin
origin = TypeEqOrigin { uo_actual :: Type
uo_actual = Type
act_kind'
, uo_expected :: Type
uo_expected = Type
exp_kind
, uo_thing :: Maybe TypedThing
uo_thing = TypedThing -> Maybe TypedThing
forall a. a -> Maybe a
Just (HsType GhcRn -> TypedThing
HsTypeRnThing HsType GhcRn
hs_ty)
, uo_visible :: Bool
uo_visible = Bool
True }
; String -> SDoc -> TcM ()
traceTc String
"checkExpectedKindX" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
hs_ty
, String -> SDoc
text String
"act_kind':" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act_kind'
, String -> SDoc
text String
"exp_kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp_kind ]
; let res_ty :: Type
res_ty = Type
ty Type -> [Type] -> Type
`mkTcAppTys` [Type]
new_args
; if Type
act_kind' (() :: Constraint) => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` Type
exp_kind
then Type -> TcM Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
res_ty
else do { Coercion
co_k <- TypeOrKind -> CtOrigin -> Type -> Type -> TcM Coercion
uType TypeOrKind
KindLevel CtOrigin
origin Type
act_kind' Type
exp_kind
; String -> SDoc -> TcM ()
traceTc String
"checkExpectedKind" ([SDoc] -> SDoc
vcat [ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act_kind
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp_kind
, Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co_k ])
; Type -> TcM Type
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
res_ty Type -> Coercion -> Type
`mkTcCastTy` Coercion
co_k) } }
where
n_exp_invis_bndrs :: Arity
n_exp_invis_bndrs = Type -> Arity
invisibleTyBndrCount Type
exp_kind
n_act_invis_bndrs :: Arity
n_act_invis_bndrs = Type -> Arity
invisibleTyBndrCount Type
act_kind
n_to_inst :: Arity
n_to_inst = Arity
n_act_invis_bndrs Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
n_exp_invis_bndrs
tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]
tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
Nothing = [Type] -> TcM [Type]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
tcHsContext (Just LHsContext GhcRn
cxt) = TcTyMode -> LHsContext GhcRn -> TcM [Type]
tc_hs_context TcTyMode
typeLevelMode LHsContext GhcRn
cxt
tcLHsPredType :: LHsType GhcRn -> TcM PredType
tcLHsPredType :: LHsType GhcRn -> TcM Type
tcLHsPredType LHsType GhcRn
pred = TcTyMode -> LHsType GhcRn -> TcM Type
tc_lhs_pred TcTyMode
typeLevelMode LHsType GhcRn
pred
tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]
tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [Type]
tc_hs_context TcTyMode
mode LHsContext GhcRn
ctxt = (GenLocated SrcSpanAnnA (HsType GhcRn) -> TcM Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> TcM [Type]
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 (TcTyMode -> LHsType GhcRn -> TcM Type
tc_lhs_pred TcTyMode
mode) (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall l e. GenLocated l e -> e
unLoc LHsContext GhcRn
GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
ctxt)
tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType
tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM Type
tc_lhs_pred TcTyMode
mode LHsType GhcRn
pred = TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
pred Type
constraintKind
tcTyVar :: Name -> TcM (TcType, TcKind)
tcTyVar :: Name -> TcM (Type, Type)
tcTyVar Name
name
= do { String -> SDoc -> TcM ()
traceTc String
"lk1" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
; TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
name
; case TcTyThing
thing of
ATyVar Name
_ TyVar
tv -> (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Type
mkTyVarTy TyVar
tv, TyVar -> Type
tyVarKind TyVar
tv)
(TcTyThing -> Maybe TyCon
tcTyThingTyCon_maybe -> Just TyCon
tc)
-> (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Type
mkTyConTy TyCon
tc, TyCon -> Type
tyConKind TyCon
tc)
AGlobal (AConLike (RealDataCon DataCon
dc))
-> do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
data_kinds Bool -> Bool -> Bool
|| DataCon -> Bool
specialPromotedDc DataCon
dc) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
Name -> PromotionErr -> TcM ()
forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name PromotionErr
NoDataKindsDC
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isFamInstTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
Name -> PromotionErr -> TcM ()
forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name PromotionErr
FamDataConPE
; let ([TyVar]
_, [TyVar]
_, [EqSpec]
_, [Type]
theta, [Scaled Type]
_, Type
_) = DataCon
-> ([TyVar], [TyVar], [EqSpec], [Type], [Scaled Type], Type)
dataConFullSig DataCon
dc
; String -> SDoc -> TcM ()
traceTc String
"tcTyVar" (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
theta SDoc -> SDoc -> SDoc
$$ Maybe Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Type] -> Maybe Type
dc_theta_illegal_constraint [Type]
theta))
; case [Type] -> Maybe Type
dc_theta_illegal_constraint [Type]
theta of
Just Type
pred -> Name -> PromotionErr -> TcM ()
forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name (PromotionErr -> TcM ()) -> PromotionErr -> TcM ()
forall a b. (a -> b) -> a -> b
$
Type -> PromotionErr
ConstrainedDataConPE Type
pred
Maybe Type
Nothing -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
; let tc :: TyCon
tc = DataCon -> TyCon
promoteDataCon DataCon
dc
; (Type, Type) -> TcM (Type, Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [], TyCon -> Type
tyConKind TyCon
tc) }
APromotionErr PromotionErr
err -> Name -> PromotionErr -> TcM (Type, Type)
forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name PromotionErr
err
TcTyThing
_ -> String -> TcTyThing -> Name -> TcM (Type, Type)
forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr String
"type" TcTyThing
thing Name
name }
where
dc_theta_illegal_constraint :: ThetaType -> Maybe PredType
dc_theta_illegal_constraint :: [Type] -> Maybe Type
dc_theta_illegal_constraint = (Type -> Bool) -> [Type] -> Maybe Type
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
isEqPred)
addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt :: forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt (L SrcSpanAnnA
_ (HsWildCardTy XWildCardTy GhcRn
_)) TcM a
thing = TcM a
thing
addTypeCtxt (L SrcSpanAnnA
_ HsType GhcRn
ty) TcM a
thing
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
doc TcM a
thing
where
doc :: SDoc
doc = String -> SDoc
text String
"In the type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
ty)
bindNamedWildCardBinders :: [Name]
-> ([(Name, TcTyVar)] -> TcM a)
-> TcM a
bindNamedWildCardBinders :: forall a. HsQTvsRn -> ([(Name, TyVar)] -> TcM a) -> TcM a
bindNamedWildCardBinders HsQTvsRn
wc_names [(Name, TyVar)] -> TcM a
thing_inside
= do { [TyVar]
wcs <- (Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> HsQTvsRn -> TcM [TyVar]
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 Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
newNamedWildTyVar HsQTvsRn
wc_names
; let wc_prs :: [(Name, TyVar)]
wc_prs = HsQTvsRn
wc_names HsQTvsRn -> [TyVar] -> [(Name, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
wcs
; [(Name, TyVar)] -> TcM a -> TcM a
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
wc_prs (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
[(Name, TyVar)] -> TcM a
thing_inside [(Name, TyVar)]
wc_prs }
newNamedWildTyVar :: Name -> TcM TcTyVar
newNamedWildTyVar :: Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
newNamedWildTyVar Name
_name
= do { Type
kind <- TcM Type
newMetaKindVar
; TcTyVarDetails
details <- MetaInfo -> TcM TcTyVarDetails
newMetaDetails MetaInfo
TauTv
; Name
wc_name <- FastString -> TcM Name
newMetaTyVarName (String -> FastString
fsLit String
"w")
; let tyvar :: TyVar
tyvar = Name -> Type -> TcTyVarDetails -> TyVar
mkTcTyVar Name
wc_name Type
kind TcTyVarDetails
details
; String -> SDoc -> TcM ()
traceTc String
"newWildTyVar" (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar)
; TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
tyvar }
tcAnonWildCardOcc :: IsExtraConstraint
-> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType
tcAnonWildCardOcc :: IsExtraConstraint -> TcTyMode -> HsType GhcRn -> Type -> TcM Type
tcAnonWildCardOcc IsExtraConstraint
is_extra (TcTyMode { mode_holes :: TcTyMode -> HoleInfo
mode_holes = Just (TcLevel
hole_lvl, HoleMode
hole_mode) })
HsType GhcRn
ty Type
exp_kind
= do { TcTyVarDetails
kv_details <- TcLevel -> TcM TcTyVarDetails
newTauTvDetailsAtLevel TcLevel
hole_lvl
; Name
kv_name <- FastString -> TcM Name
newMetaTyVarName (String -> FastString
fsLit String
"k")
; TcTyVarDetails
wc_details <- TcLevel -> TcM TcTyVarDetails
newTauTvDetailsAtLevel TcLevel
hole_lvl
; Name
wc_name <- FastString -> TcM Name
newMetaTyVarName (String -> FastString
fsLit String
wc_nm)
; let kv :: TyVar
kv = Name -> Type -> TcTyVarDetails -> TyVar
mkTcTyVar Name
kv_name Type
liftedTypeKind TcTyVarDetails
kv_details
wc_kind :: Type
wc_kind = TyVar -> Type
mkTyVarTy TyVar
kv
wc_tv :: TyVar
wc_tv = Name -> Type -> TcTyVarDetails -> TyVar
mkTcTyVar Name
wc_name Type
wc_kind TcTyVarDetails
wc_details
; String -> SDoc -> TcM ()
traceTc String
"tcAnonWildCardOcc" (TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
hole_lvl SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
emit_holes)
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
emit_holes (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
IsExtraConstraint -> TyVar -> TcM ()
emitAnonTypeHole IsExtraConstraint
is_extra TyVar
wc_tv
; (() :: Constraint) =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
ty (TyVar -> Type
mkTyVarTy TyVar
wc_tv) Type
wc_kind Type
exp_kind }
where
wc_nm :: String
wc_nm = case HoleMode
hole_mode of
HoleMode
HM_Sig -> String
"w"
HoleMode
HM_FamPat -> String
"_"
HoleMode
HM_VTA -> String
"w"
HoleMode
HM_TyAppPat -> String
"_"
emit_holes :: Bool
emit_holes = case HoleMode
hole_mode of
HoleMode
HM_Sig -> Bool
True
HoleMode
HM_FamPat -> Bool
False
HoleMode
HM_VTA -> Bool
False
HoleMode
HM_TyAppPat -> Bool
False
tcAnonWildCardOcc IsExtraConstraint
is_extra TcTyMode
_ HsType GhcRn
_ Type
_
= TcRnMessage -> TcM Type
forall a. TcRnMessage -> TcM a
failWith (TcRnMessage -> TcM Type) -> TcRnMessage -> TcM Type
forall a b. (a -> b) -> a -> b
$ Maybe Name
-> BadAnonWildcardContext -> Maybe HsDocContext -> TcRnMessage
TcRnIllegalWildcardInType Maybe Name
forall a. Maybe a
Nothing BadAnonWildcardContext
reason Maybe HsDocContext
forall a. Maybe a
Nothing
where
reason :: BadAnonWildcardContext
reason =
case IsExtraConstraint
is_extra of
IsExtraConstraint
YesExtraConstraint ->
SoleExtraConstraintWildcardAllowed -> BadAnonWildcardContext
ExtraConstraintWildcardNotAllowed
SoleExtraConstraintWildcardAllowed
SoleExtraConstraintWildcardNotAllowed
IsExtraConstraint
NoExtraConstraint ->
BadAnonWildcardContext
WildcardsNotAllowedAtAll
data InitialKindStrategy
= InitialKindCheck SAKS_or_CUSK
| InitialKindInfer
data SAKS_or_CUSK
= SAKS Kind
| CUSK
instance Outputable SAKS_or_CUSK where
ppr :: SAKS_or_CUSK -> SDoc
ppr (SAKS Type
k) = String -> SDoc
text String
"SAKS" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k
ppr SAKS_or_CUSK
CUSK = String -> SDoc
text String
"CUSK"
kcDeclHeader
:: InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TcTyCon
(InitialKindCheck SAKS_or_CUSK
msig) = SAKS_or_CUSK
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcCheckDeclHeader SAKS_or_CUSK
msig
kcDeclHeader InitialKindStrategy
InitialKindInfer = Name
-> TyConFlavour -> LHsQTyVars GhcRn -> TcM ContextKind -> TcM TyCon
kcInferDeclHeader
kcCheckDeclHeader
:: SAKS_or_CUSK
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM PolyTcTyCon
(SAKS Type
sig) = Type
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcCheckDeclHeader_sig Type
sig
kcCheckDeclHeader SAKS_or_CUSK
CUSK = Name
-> TyConFlavour -> LHsQTyVars GhcRn -> TcM ContextKind -> TcM TyCon
kcCheckDeclHeader_cusk
kcCheckDeclHeader_cusk
:: Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM PolyTcTyCon
Name
name TyConFlavour
flav
(HsQTvs { hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass
hsq_ext = XHsQTvs GhcRn
kv_ns
, hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsq_explicit = [LHsTyVarBndr () GhcRn]
hs_tvs }) TcM ContextKind
kc_res_ki
= Name -> TyConFlavour -> TcM TyCon -> TcM TyCon
forall a. Name -> TyConFlavour -> TcM a -> TcM a
addTyConFlavCtxt Name
name TyConFlavour
flav (TcM TyCon -> TcM TyCon) -> TcM TyCon -> TcM TyCon
forall a b. (a -> b) -> a -> b
$
do { SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo SkolemInfoAnon
skol_info_anon
; (TcLevel
tclvl, WantedConstraints
wanted, ([TyVar]
scoped_kvs, ([TyVar]
tc_tvs, Type
res_kind)))
<- String
-> TcM ([TyVar], ([TyVar], Type))
-> TcM (TcLevel, WantedConstraints, ([TyVar], ([TyVar], Type)))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"kcCheckDeclHeader_cusk" (TcM ([TyVar], ([TyVar], Type))
-> TcM (TcLevel, WantedConstraints, ([TyVar], ([TyVar], Type))))
-> TcM ([TyVar], ([TyVar], Type))
-> TcM (TcLevel, WantedConstraints, ([TyVar], ([TyVar], Type)))
forall a b. (a -> b) -> a -> b
$
SkolemInfo
-> HsQTvsRn
-> TcM ([TyVar], Type)
-> TcM ([TyVar], ([TyVar], Type))
forall a. SkolemInfo -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Skol SkolemInfo
skol_info HsQTvsRn
XHsQTvs GhcRn
kv_ns (TcM ([TyVar], Type) -> TcM ([TyVar], ([TyVar], Type)))
-> TcM ([TyVar], Type) -> TcM ([TyVar], ([TyVar], Type))
forall a b. (a -> b) -> a -> b
$
SkolemInfo
-> ContextKind
-> [LHsTyVarBndr () GhcRn]
-> TcM Type
-> TcM ([TyVar], Type)
forall a.
SkolemInfo
-> ContextKind
-> [LHsTyVarBndr () GhcRn]
-> TcM a
-> TcM ([TyVar], a)
bindExplicitTKBndrs_Q_Skol SkolemInfo
skol_info ContextKind
ctxt_kind [LHsTyVarBndr () GhcRn]
hs_tvs (TcM Type -> TcM ([TyVar], Type))
-> TcM Type -> TcM ([TyVar], Type)
forall a b. (a -> b) -> a -> b
$
ContextKind -> TcM Type
newExpectedKind (ContextKind -> TcM Type) -> TcM ContextKind -> TcM Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TcM ContextKind
kc_res_ki
; let spec_req_tkvs :: [TyVar]
spec_req_tkvs = [TyVar]
scoped_kvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
tc_tvs
all_kinds :: [Type]
all_kinds = Type
res_kind Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (TyVar -> Type) -> [TyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
tyVarKind [TyVar]
spec_req_tkvs
; CandidatesQTvs
candidates <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfKinds [Type]
all_kinds
; [TyVar]
inferred <- SkolemInfo
-> NonStandardDefaultingStrategy -> CandidatesQTvs -> TcM [TyVar]
quantifyTyVars SkolemInfo
skol_info NonStandardDefaultingStrategy
DefaultNonStandardTyVars (CandidatesQTvs -> TcM [TyVar]) -> CandidatesQTvs -> TcM [TyVar]
forall a b. (a -> b) -> a -> b
$
CandidatesQTvs
candidates CandidatesQTvs -> [TyVar] -> CandidatesQTvs
`delCandidates` [TyVar]
spec_req_tkvs
; [TyVar]
scoped_kvs <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TyVar] -> TcM [TyVar]
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 TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
zonkTyCoVarKind [TyVar]
scoped_kvs
; [TyVar]
tc_tvs <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TyVar] -> TcM [TyVar]
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 TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
zonkTyCoVarKind [TyVar]
tc_tvs
; Type
res_kind <- Type -> TcM Type
zonkTcType Type
res_kind
; let mentioned_kv_set :: TyVarSet
mentioned_kv_set = CandidatesQTvs -> TyVarSet
candidateKindVars CandidatesQTvs
candidates
specified :: [TyVar]
specified = [TyVar] -> [TyVar]
scopedSort [TyVar]
scoped_kvs
all_tcbs :: [TyConBinder]
all_tcbs = ArgFlag -> [TyVar] -> [TyConBinder]
mkNamedTyConBinders ArgFlag
Inferred [TyVar]
inferred
[TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
++ ArgFlag -> [TyVar] -> [TyConBinder]
mkNamedTyConBinders ArgFlag
Specified [TyVar]
specified
[TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
++ (TyVar -> TyConBinder) -> [TyVar] -> [TyConBinder]
forall a b. (a -> b) -> [a] -> [b]
map (TyVarSet -> TyVar -> TyConBinder
mkRequiredTyConBinder TyVarSet
mentioned_kv_set) [TyVar]
tc_tvs
; ([TyConBinder]
eta_tcbs, Type
res_kind) <- TyConFlavour
-> SkolemInfo -> [TyConBinder] -> Type -> TcM ([TyConBinder], Type)
etaExpandAlgTyCon TyConFlavour
flav SkolemInfo
skol_info [TyConBinder]
all_tcbs Type
res_kind
; let all_tv_prs :: [(Name, TyVar)]
all_tv_prs = [TyVar] -> [(Name, TyVar)]
mkTyVarNamePairs ([TyVar]
scoped_kvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
tc_tvs)
final_tcbs :: [TyConBinder]
final_tcbs = [TyConBinder]
all_tcbs [TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
`chkAppend` [TyConBinder]
eta_tcbs
tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Type
-> [(Name, TyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon Name
name [TyConBinder]
final_tcbs Type
res_kind [(Name, TyVar)]
all_tv_prs
Bool
True
TyConFlavour
flav
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcM ()
reportUnsolvedEqualities SkolemInfo
skol_info ([TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
final_tcbs)
TcLevel
tclvl WantedConstraints
wanted
; TyCon -> TcM ()
checkTyConTelescope TyCon
tycon
; String -> SDoc -> TcM ()
traceTc String
"kcCheckDeclHeader_cusk " (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"name" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
, String -> SDoc
text String
"candidates" SDoc -> SDoc -> SDoc
<+> CandidatesQTvs -> SDoc
forall a. Outputable a => a -> SDoc
ppr CandidatesQTvs
candidates
, String -> SDoc
text String
"mentioned_kv_set" SDoc -> SDoc -> SDoc
<+> TyVarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVarSet
mentioned_kv_set
, String -> SDoc
text String
"kv_ns" SDoc -> SDoc -> SDoc
<+> HsQTvsRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsQTvsRn
XHsQTvs GhcRn
kv_ns
, String -> SDoc
text String
"hs_tvs" SDoc -> SDoc -> SDoc
<+> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr () GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
hs_tvs
, String -> SDoc
text String
"scoped_kvs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
scoped_kvs
, String -> SDoc
text String
"spec_req_tvs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
spec_req_tkvs
, String -> SDoc
text String
"all_kinds" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
all_kinds
, String -> SDoc
text String
"tc_tvs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
tc_tvs
, String -> SDoc
text String
"res_kind" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
res_kind
, String -> SDoc
text String
"inferred" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
inferred
, String -> SDoc
text String
"specified" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
specified
, String -> SDoc
text String
"final_tcbs" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
final_tcbs
, String -> SDoc
text String
"mkTyConKind final_tc_bndrs res_kind"
SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([TyConBinder] -> Type -> Type
mkTyConKind [TyConBinder]
final_tcbs Type
res_kind)
, String -> SDoc
text String
"all_tv_prs" SDoc -> SDoc -> SDoc
<+> [(Name, TyVar)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
all_tv_prs ]
; TyCon -> TcM TyCon
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
where
skol_info_anon :: SkolemInfoAnon
skol_info_anon = TyConFlavour -> Name -> SkolemInfoAnon
TyConSkol TyConFlavour
flav Name
name
ctxt_kind :: ContextKind
ctxt_kind | TyConFlavour -> Bool
tcFlavourIsOpen TyConFlavour
flav = Type -> ContextKind
TheKind Type
liftedTypeKind
| Bool
otherwise = ContextKind
AnyKind
kcInferDeclHeader
:: Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM MonoTcTyCon
Name
name TyConFlavour
flav
(HsQTvs { hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass
hsq_ext = XHsQTvs GhcRn
kv_ns
, hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsq_explicit = [LHsTyVarBndr () GhcRn]
hs_tvs }) TcM ContextKind
kc_res_ki
= Name -> TyConFlavour -> TcM TyCon -> TcM TyCon
forall a. Name -> TyConFlavour -> TcM a -> TcM a
addTyConFlavCtxt Name
name TyConFlavour
flav (TcM TyCon -> TcM TyCon) -> TcM TyCon -> TcM TyCon
forall a b. (a -> b) -> a -> b
$
do { ([TyVar]
scoped_kvs, ([TyVar]
tc_tvs, Type
res_kind))
<- HsQTvsRn -> TcM ([TyVar], Type) -> TcM ([TyVar], ([TyVar], Type))
forall a. HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Tv HsQTvsRn
XHsQTvs GhcRn
kv_ns (TcM ([TyVar], Type) -> TcM ([TyVar], ([TyVar], Type)))
-> TcM ([TyVar], Type) -> TcM ([TyVar], ([TyVar], Type))
forall a b. (a -> b) -> a -> b
$
ContextKind
-> [LHsTyVarBndr () GhcRn] -> TcM Type -> TcM ([TyVar], Type)
forall a.
ContextKind -> [LHsTyVarBndr () GhcRn] -> TcM a -> TcM ([TyVar], a)
bindExplicitTKBndrs_Q_Tv ContextKind
ctxt_kind [LHsTyVarBndr () GhcRn]
hs_tvs (TcM Type -> TcM ([TyVar], Type))
-> TcM Type -> TcM ([TyVar], Type)
forall a b. (a -> b) -> a -> b
$
ContextKind -> TcM Type
newExpectedKind (ContextKind -> TcM Type) -> TcM ContextKind -> TcM Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TcM ContextKind
kc_res_ki
; let
tc_binders :: [TyConBinder]
tc_binders = AnonArgFlag -> [TyVar] -> [TyConBinder]
mkAnonTyConBinders AnonArgFlag
VisArg [TyVar]
tc_tvs
all_tv_prs :: [(Name, TyVar)]
all_tv_prs = [TyVar] -> [(Name, TyVar)]
mkTyVarNamePairs ([TyVar]
scoped_kvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
tc_tvs)
tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Type
-> [(Name, TyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon Name
name [TyConBinder]
tc_binders Type
res_kind [(Name, TyVar)]
all_tv_prs
Bool
False
TyConFlavour
flav
; String -> SDoc -> TcM ()
traceTc String
"kcInferDeclHeader: not-cusk" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, HsQTvsRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsQTvsRn
XHsQTvs GhcRn
kv_ns, [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr () GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
hs_tvs
, [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
scoped_kvs
, [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tc_tvs, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([TyConBinder] -> Type -> Type
mkTyConKind [TyConBinder]
tc_binders Type
res_kind) ]
; TyCon -> TcM TyCon
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
where
ctxt_kind :: ContextKind
ctxt_kind | TyConFlavour -> Bool
tcFlavourIsOpen TyConFlavour
flav = Type -> ContextKind
TheKind Type
liftedTypeKind
| Bool
otherwise = ContextKind
AnyKind
kcCheckDeclHeader_sig
:: Kind
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM PolyTcTyCon
Type
sig_kind Name
name TyConFlavour
flav
(HsQTvs { hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass
hsq_ext = XHsQTvs GhcRn
implicit_nms
, hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsq_explicit = [LHsTyVarBndr () GhcRn]
hs_tv_bndrs }) TcM ContextKind
kc_res_ki
= Name -> TyConFlavour -> TcM TyCon -> TcM TyCon
forall a. Name -> TyConFlavour -> TcM a -> TcM a
addTyConFlavCtxt Name
name TyConFlavour
flav (TcM TyCon -> TcM TyCon) -> TcM TyCon -> TcM TyCon
forall a b. (a -> b) -> a -> b
$
do { SkolemInfo
skol_info <- SkolemInfoAnon -> IOEnv (Env TcGblEnv TcLclEnv) SkolemInfo
forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (TyConFlavour -> Name -> SkolemInfoAnon
TyConSkol TyConFlavour
flav Name
name)
; ([TyConBinder]
sig_tcbs :: [TcTyConBinder], Type
sig_res_kind :: Kind)
<- SkolemInfo
-> InScopeSet -> [OccName] -> Type -> TcM ([TyConBinder], Type)
splitTyConKind SkolemInfo
skol_info InScopeSet
emptyInScopeSet
((GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> OccName)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> OccName
forall a. NamedThing a => a -> OccName
getOccName [LHsTyVarBndr () GhcRn]
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
hs_tv_bndrs) Type
sig_kind
; String -> SDoc -> TcM ()
traceTc String
"kcCheckDeclHeader_sig {" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"sig_kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sig_kind
, String -> SDoc
text String
"sig_tcbs:" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
sig_tcbs
, String -> SDoc
text String
"sig_res_kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sig_res_kind ]
; (TcLevel
tclvl, WantedConstraints
wanted, ([TyVar]
implicit_tvs, ([TyConBinder]
skol_tcbs, ([TyConBinder]
extra_tcbs, Type
tycon_res_kind))))
<- String
-> TcM ([TyVar], ([TyConBinder], ([TyConBinder], Type)))
-> TcM
(TcLevel, WantedConstraints,
([TyVar], ([TyConBinder], ([TyConBinder], Type))))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"kcCheckDeclHeader_sig" (TcM ([TyVar], ([TyConBinder], ([TyConBinder], Type)))
-> TcM
(TcLevel, WantedConstraints,
([TyVar], ([TyConBinder], ([TyConBinder], Type)))))
-> TcM ([TyVar], ([TyConBinder], ([TyConBinder], Type)))
-> TcM
(TcLevel, WantedConstraints,
([TyVar], ([TyConBinder], ([TyConBinder], Type))))
forall a b. (a -> b) -> a -> b
$
HsQTvsRn
-> TcM ([TyConBinder], ([TyConBinder], Type))
-> TcM ([TyVar], ([TyConBinder], ([TyConBinder], Type)))
forall a. HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Tv HsQTvsRn
XHsQTvs GhcRn
implicit_nms (TcM ([TyConBinder], ([TyConBinder], Type))
-> TcM ([TyVar], ([TyConBinder], ([TyConBinder], Type))))
-> TcM ([TyConBinder], ([TyConBinder], Type))
-> TcM ([TyVar], ([TyConBinder], ([TyConBinder], Type)))
forall a b. (a -> b) -> a -> b
$
[TyConBinder]
-> Type
-> [LHsTyVarBndr () GhcRn]
-> ([TyConBinder] -> Type -> TcM ([TyConBinder], Type))
-> TcM ([TyConBinder], ([TyConBinder], Type))
forall a.
[TyConBinder]
-> Type
-> [LHsTyVarBndr () GhcRn]
-> ([TyConBinder] -> Type -> TcM a)
-> TcM ([TyConBinder], a)
matchUpSigWithDecl [TyConBinder]
sig_tcbs Type
sig_res_kind [LHsTyVarBndr () GhcRn]
hs_tv_bndrs (([TyConBinder] -> Type -> TcM ([TyConBinder], Type))
-> TcM ([TyConBinder], ([TyConBinder], Type)))
-> ([TyConBinder] -> Type -> TcM ([TyConBinder], Type))
-> TcM ([TyConBinder], ([TyConBinder], Type))
forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
excess_sig_tcbs Type
sig_res_kind ->
do {
; ContextKind
ctx_k <- TcM ContextKind
kc_res_ki
; let n_invis_tcbs :: Arity
n_invis_tcbs = (TyConBinder -> Bool) -> [TyConBinder] -> Arity
forall a. (a -> Bool) -> [a] -> Arity
countWhile TyConBinder -> Bool
forall tv. VarBndr tv TyConBndrVis -> Bool
isInvisibleTyConBinder [TyConBinder]
excess_sig_tcbs
invis_arity :: Arity
invis_arity = case ContextKind
ctx_k of
ContextKind
AnyKind -> Arity
n_invis_tcbs
ContextKind
OpenKind -> Arity
n_invis_tcbs
TheKind Type
ki -> Arity
0 Arity -> Arity -> Arity
forall a. Ord a => a -> a -> a
`max` (Arity
n_invis_tcbs Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Type -> Arity
invisibleTyBndrCount Type
ki)
; let ([TyConBinder]
invis_tcbs, [TyConBinder]
resid_tcbs) = Arity -> [TyConBinder] -> ([TyConBinder], [TyConBinder])
forall a. Arity -> [a] -> ([a], [a])
splitAt Arity
invis_arity [TyConBinder]
excess_sig_tcbs
; let sig_res_kind' :: Type
sig_res_kind' = [TyConBinder] -> Type -> Type
mkTyConKind [TyConBinder]
resid_tcbs Type
sig_res_kind
; String -> SDoc -> TcM ()
traceTc String
"kcCheckDeclHeader_sig 2" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [ [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
excess_sig_tcbs
, Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
invis_arity, [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
invis_tcbs
, Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
n_invis_tcbs ]
; case ContextKind
ctx_k of
ContextKind
AnyKind -> () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ContextKind
_ -> do { Type
res_ki <- ContextKind -> TcM Type
newExpectedKind ContextKind
ctx_k
; TcM Coercion -> TcM ()
forall a. TcM a -> TcM ()
discardResult (Maybe TypedThing -> Type -> Type -> TcM Coercion
unifyKind Maybe TypedThing
forall a. Maybe a
Nothing Type
sig_res_kind' Type
res_ki) }
; if [TyConBinder] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyConBinder]
resid_tcbs Bool -> Bool -> Bool
|| Bool -> Bool
not (TyConFlavour -> Bool
needsEtaExpansion TyConFlavour
flav)
then ([TyConBinder], Type) -> TcM ([TyConBinder], Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyConBinder]
invis_tcbs, Type
sig_res_kind')
else ([TyConBinder], Type) -> TcM ([TyConBinder], Type)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyConBinder]
excess_sig_tcbs, Type
sig_res_kind)
}
; let all_tcbs :: [TyConBinder]
all_tcbs = [TyConBinder]
skol_tcbs [TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
++ [TyConBinder]
extra_tcbs
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcM ()
reportUnsolvedEqualities SkolemInfo
skol_info ([TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
all_tcbs) TcLevel
tclvl WantedConstraints
wanted
; [TyVar]
implicit_tvs <- [TyVar] -> TcM [TyVar]
(() :: Constraint) => [TyVar] -> TcM [TyVar]
zonkTcTyVarsToTcTyVars [TyVar]
implicit_tvs
; let implicit_prs :: [(Name, TyVar)]
implicit_prs = HsQTvsRn
XHsQTvs GhcRn
implicit_nms HsQTvsRn -> [TyVar] -> [(Name, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
implicit_tvs
; [(Name, TyVar)] -> TcM ()
checkForDuplicateScopedTyVars [(Name, TyVar)]
implicit_prs
; let swizzle_env :: VarEnv Name
swizzle_env = [(TyVar, Name)] -> VarEnv Name
forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv (((Name, TyVar) -> (TyVar, Name))
-> [(Name, TyVar)] -> [(TyVar, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, TyVar) -> (TyVar, Name)
forall a b. (a, b) -> (b, a)
swap [(Name, TyVar)]
implicit_prs)
(TCvSubst
subst, [TyConBinder]
swizzled_tcbs) = (TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder))
-> TCvSubst -> [TyConBinder] -> (TCvSubst, [TyConBinder])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (VarEnv Name -> TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder)
swizzleTcb VarEnv Name
swizzle_env) TCvSubst
emptyTCvSubst [TyConBinder]
all_tcbs
swizzled_kind :: Type
swizzled_kind = (() :: Constraint) => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type