{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonadComprehensions #-}
{-# 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 hiding ( head, init, last, tail )
import GHC.Hs
import GHC.Rename.Utils
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Origin
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.Tc.Utils.TcType
import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN,
tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs,
tcInstTypeBndrs )
import GHC.Core.Type
import GHC.Core.Predicate
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr
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.Infinite ( Infinite (..) )
import qualified GHC.Data.List.Infinite as Inf
import GHC.Data.List.SetOps
import GHC.Data.Maybe
import GHC.Data.Bag( unitBag )
import Data.Function ( on )
import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
import qualified Data.List.NonEmpty as NE
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 [] = forall a. HasCallStack => 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
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LocatedA hs_ty
hs_ty) forall a b. (a -> b) -> a -> b
$
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (forall hs_ty.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> SDoc
pprSigCtxt UserTypeCtxt
ctxt LocatedA hs_ty
hs_ty) 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 (forall doc. IsLine doc => String -> doc
text String
"In the type signature:")
Arity
2 (forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Name
n forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr LocatedA hs_ty
hs_ty)
| Bool
otherwise
= SDoc -> Arity -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"In" forall doc. IsLine doc => doc -> doc -> doc
<+> UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
colon)
Arity
2 (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 (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 }))
= 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
sig_ty forall a b. (a -> b) -> a -> b
$
do { (HsOuterTyVarBndrs Specificity GhcTc, Type)
_ <- forall a.
HsOuterSigTyVarBndrs GhcRn
-> TcM a -> TcM (HsOuterTyVarBndrs Specificity GhcTc, a)
bindOuterSigTKBndrs_Tv HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs forall a b. (a -> b) -> a -> b
$
LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
liftedTypeKind
; 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
= forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
sig_ctxt LHsSigType GhcRn
sig_ty forall a b. (a -> b) -> a -> b
$
do { SkolemInfo
skol_info <- 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
; 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
= forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt LHsSigType GhcRn
sig_ty forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcM ()
traceTc String
"tcHsSigType {" (forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
sig_ty)
; SkolemInfo
skol_info <- 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" (forall a. Outputable a => a -> SDoc
ppr Implication
implic)
; WantedConstraints -> TcM ()
simplifyAndEmitFlatConstraints (Bag Implication -> WantedConstraints
mkImplicWC (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 }" (forall a. Outputable a => a -> SDoc
ppr Type
ty)
; 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
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { (TcLevel
tc_lvl, WantedConstraints
wanted, (Type
exp_kind, (HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs, Type
ty)))
<- forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tc_lhs_sig_type" forall a b. (a -> b) -> a -> b
$
do { Type
exp_kind <- ContextKind -> TcM Type
newExpectedKind ContextKind
ctxt_kind
; (HsOuterTyVarBndrs Specificity GhcTc, Type)
stuff <- 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 forall a b. (a -> b) -> a -> b
$
LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
exp_kind
; 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" (forall a. Outputable a => a -> SDoc
ppr HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs)
; HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs <- forall flag.
HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc)
scopedSortOuter HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs
; let [VarBndr TyVar Specificity]
outer_tv_bndrs :: [InvisTVBinder] = HsOuterTyVarBndrs Specificity GhcTc -> [VarBndr TyVar Specificity]
outerTyVarBndrs HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs
ty1 :: Type
ty1 = [VarBndr TyVar Specificity] -> Type -> Type
mkInvisForAllTys [VarBndr TyVar Specificity]
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
; 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
; forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
tidy_env2, SDoc -> Arity -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"The kind" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
exp_kind)
Arity
2 (forall doc. IsLine doc => String -> doc
text String
"of type signature:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr LHsSigType 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))
= forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt LHsSigType GhcRn
ksig 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
; 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
= forall r. TcM r -> TcM r
checkNoErrs 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 }))
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcM ()
traceTc String
"tc_top_lhs_type {" (forall a. Outputable a => a -> SDoc
ppr HsSigType GhcRn
sig_ty)
; SkolemInfo
skol_info <- forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo SkolemInfoAnon
skol_info_anon
; (TcLevel
tclvl, WantedConstraints
wanted, (HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs, Type
ty))
<- forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tc_top_lhs_type" forall a b. (a -> b) -> a -> b
$
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 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 <- forall flag.
HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc)
scopedSortOuter HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs
; let outer_tv_bndrs :: [VarBndr TyVar Specificity]
outer_tv_bndrs = HsOuterTyVarBndrs Specificity GhcTc -> [VarBndr TyVar Specificity]
outerTyVarBndrs HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs
ty1 :: Type
ty1 = [VarBndr TyVar Specificity] -> Type -> Type
mkInvisForAllTys [VarBndr TyVar Specificity]
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 }" (forall doc. IsDoc doc => [doc] -> doc
vcat [forall a. Outputable a => a -> SDoc
ppr HsSigType GhcRn
sig_ty, forall a. Outputable a => a -> SDoc
ppr Type
final_ty])
; 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 (HasDebugCallStack => Type -> Type
typeKind Type
pred)
; case Type -> Maybe (Class, [Type])
getClassPredTys_maybe Type
pred of
Just (Class
cls, [Type]
tys) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
tvs, Class
cls, [Type]
tys, forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Type]
kind_args)
Maybe (Class, [Type])
Nothing -> forall a. TcRnMessage -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$ LHsSigType GhcRn -> TcRnMessage
TcRnIllegalDerivingItem LHsSigType 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 -> forall ds a. ds -> TcM (ds, [a])
boring_case forall a. Maybe a
Nothing
Just (L SrcSpanAnn' (EpAnn NoEpAnns)
loc DerivStrategy GhcRn
ds) ->
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' (EpAnn NoEpAnns)
loc 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn 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
_) = forall ds a. ds -> TcM (ds, [a])
boring_case (forall pass. XStockStrategy pass -> DerivStrategy pass
StockStrategy NoExtField
noExtField)
tc_deriv_strategy (AnyclassStrategy XAnyClassStrategy GhcRn
_) = forall ds a. ds -> TcM (ds, [a])
boring_case (forall pass. XAnyClassStrategy pass -> DerivStrategy pass
AnyclassStrategy NoExtField
noExtField)
tc_deriv_strategy (NewtypeStrategy XNewtypeStrategy GhcRn
_) = forall ds a. ds -> TcM (ds, [a])
boring_case (forall pass. XNewtypeStrategy pass -> DerivStrategy pass
NewtypeStrategy NoExtField
noExtField)
tc_deriv_strategy (ViaStrategy XViaStrategy GhcRn
hs_sig)
= do { Type
ty <- UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcTopLHsType UserTypeCtxt
DerivClauseCtxt XViaStrategy GhcRn
hs_sig
; rec { ([TyVar]
via_tvs, Type
via_pred) <- SkolemInfoAnon -> Type -> TcM ([TyVar], Type)
tcSkolemiseInvisibleBndrs (Type -> SkolemInfoAnon
DerivSkol Type
via_pred) Type
ty }
; forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy 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 = 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
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsSigType GhcRn
hs_inst_ty) 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
; 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 <- forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty forall a b. (a -> b) -> a -> b
$
forall a. String -> TcM a -> TcM a
solveEqualities String
"tcHsTypeApp" forall a b. (a -> b) -> a -> b
$
forall a. HsQTvsRn -> ([(Name, TyVar)] -> TcM a) -> TcM a
bindNamedWildCardBinders XHsWC GhcRn (LHsType GhcRn)
sig_wcs 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
; 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 {" forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc, forall doc. IsLine doc => String -> doc
text String
"arity:" forall doc. IsLine doc => doc -> doc -> doc
<+> 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 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 }" forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc, forall doc. IsLine doc => String -> doc
text String
"res_kind:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
res_kind ]
; 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 = forall a an. a -> LocatedAn an a
noLocA (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted (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 = forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty 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 = forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty 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
= forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty 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
; 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)
= forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
lhs_ty forall a b. (a -> b) -> a -> b
$
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc 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
= forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty 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 (forall l e. GenLocated l e -> e
unLoc LHsType 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 = 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
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyMode { mode_tyki :: TypeOrKind
mode_tyki = TypeOrKind
tyki
, mode_holes :: HoleInfo
mode_holes = forall a. a -> Maybe a
Just (TcLevel
lvl,HoleMode
hm) }) }
instance Outputable HoleMode where
ppr :: HoleMode -> SDoc
ppr HoleMode
HM_Sig = forall doc. IsLine doc => String -> doc
text String
"HM_Sig"
ppr HoleMode
HM_FamPat = forall doc. IsLine doc => String -> doc
text String
"HM_FamPat"
ppr HoleMode
HM_VTA = forall doc. IsLine doc => String -> doc
text String
"HM_VTA"
ppr HoleMode
HM_TyAppPat = forall doc. IsLine doc => String -> doc
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 })
= forall doc. IsLine doc => String -> doc
text String
"TcTyMode" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => doc -> doc
braces (forall doc. IsLine doc => [doc] -> doc
sep [ forall a. Outputable a => a -> SDoc
ppr TypeOrKind
tyki forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma
, 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)
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
span 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 :: HasDebugCallStack => 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
; HasDebugCallStack =>
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" (forall a. Outputable a => a -> SDoc
ppr LHsType GhcRn
ty forall doc. IsDoc doc => doc -> doc -> doc
$$ 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'
; forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty', Type
sig') }
tc_infer_hs_type TcTyMode
mode (HsSpliceTy (HsUntypedSpliceTop ThModFinalizers
_ GenLocated SrcSpanAnnA (HsType GhcRn)
ty) HsUntypedSplice GhcRn
_)
= TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode GenLocated SrcSpanAnnA (HsType GhcRn)
ty
tc_infer_hs_type TcTyMode
_ (HsSpliceTy (HsUntypedSpliceNested Name
n) HsUntypedSplice GhcRn
s) = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tc_infer_hs_type: invalid nested splice" (forall (p :: Pass).
OutputableBndrId p =>
Bool -> Maybe Name -> HsUntypedSplice (GhcPass p) -> SDoc
pprUntypedSplice Bool
True (forall a. a -> Maybe a
Just Name
n) HsUntypedSplice GhcRn
s)
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 <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
let subst_prs :: [(Unique, TcTyVar)]
subst_prs :: [(Unique, TyVar)]
subst_prs = [ (forall a. Uniquable a => a -> Unique
getUnique Name
nm, TyVar
tv)
| ATyVar Name
nm TyVar
tv <- forall a. NameEnv a -> [a]
nonDetNameEnvElts (TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
env) ]
subst :: Subst
subst = InScopeSet -> TvSubstEnv -> Subst
mkTvSubst
([TyVar] -> InScopeSet
mkInScopeSetList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Unique, TyVar)]
subst_prs)
(forall elt key. [(Unique, elt)] -> UniqFM key elt
listToUFM_Directly forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyVar -> Type
mkTyVarTy) [(Unique, TyVar)]
subst_prs)
ty' :: Type
ty' = HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst XXType GhcRn
ty
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty', HasDebugCallStack => Type -> Type
typeKind Type
ty')
tc_infer_hs_type TcTyMode
_ (HsExplicitListTy XExplicitListTy GhcRn
_ PromotionFlag
_ [LHsType GhcRn]
tys)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsType GhcRn]
tys
= forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Type
mkTyConTy TyCon
promotedNilDataCon,
[TyVar] -> Type -> Type
mkSpecForAllTys [TyVar
alphaTyVar] 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
; 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
= forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
span 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
_
= forall a. TcRnMessage -> TcM a
failWith forall a b. (a -> b) -> a -> b
$ HsType GhcRn -> HsSrcBang -> TcRnMessage
TcRnUnexpectedAnnotation HsType GhcRn
ty HsSrcBang
bang
tc_hs_type TcTyMode
_ ty :: HsType GhcRn
ty@(HsRecTy {}) Type
_
= forall a. TcRnMessage -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$ HsType GhcRn -> TcRnMessage
TcRnIllegalRecordSyntax HsType GhcRn
ty
tc_hs_type TcTyMode
mode (HsSpliceTy (HsUntypedSpliceTop ThModFinalizers
mod_finalizers GenLocated SrcSpanAnnA (HsType GhcRn)
ty) HsUntypedSplice GhcRn
_)
Type
exp_kind
= do ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode GenLocated SrcSpanAnnA (HsType GhcRn)
ty Type
exp_kind
tc_hs_type TcTyMode
_ (HsSpliceTy (HsUntypedSpliceNested Name
n) HsUntypedSplice GhcRn
s) Type
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tc_hs_type: invalid nested splice" (forall (p :: Pass).
OutputableBndrId p =>
Bool -> Maybe Name -> HsUntypedSplice (GhcPass p) -> SDoc
pprUntypedSplice Bool
True (forall a. a -> Maybe a
Just Name
n) HsUntypedSplice GhcRn
s)
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 forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unrestrictedFunTyConKey
= TcTyMode
-> HsArrow GhcRn
-> LHsType GhcRn
-> LHsType GhcRn
-> Type
-> TcM Type
tc_fun_type TcTyMode
mode (forall pass. LHsUniToken "->" "\8594" pass -> HsArrow pass
HsUnrestrictedArrow 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') <- forall a.
TcTyMode
-> HsForAllTelescope GhcRn -> TcM a -> TcM ([TcTyVarBinder], a)
tcTKTelescope TcTyMode
mode HsForAllTelescope GhcRn
tele forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty Type
exp_kind
; 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
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall l e. GenLocated l e -> e
unLoc LHsContext GhcRn
ctxt)
= TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
rn_ty Type
exp_kind
| Type -> Bool
isConstraintLikeKind 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
; forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => [Type] -> Type -> Type
tcMkDFunPhiTy [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
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (forall l e. GenLocated l e -> e
unLoc LHsType GhcRn
rn_ty) (HasDebugCallStack => [Type] -> Type -> Type
tcMkPhiTy [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
; HasDebugCallStack =>
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" (forall a. Outputable a => a -> SDoc
ppr [LHsType GhcRn]
hs_tys) 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" (forall a. Outputable a => a -> SDoc
ppr [LHsType GhcRn]
hs_tys)
; ([Type]
tys, [Type]
kinds) <- 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]
hs_tys
; [Type]
kinds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$
HasDebugCallStack =>
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) <- forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [LHsType 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' (forall a b. (a -> b) -> [a] -> [b]
map (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 = forall (t :: * -> *) a. Foldable t => t a -> Arity
length [LHsType GhcRn]
hs_tys
; [Type]
arg_kinds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\GenLocated SrcSpanAnnA (HsType GhcRn)
_ -> TcM Type
newOpenTypeKind) [LHsType GhcRn]
hs_tys
; [Type]
tau_tys <- 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]
hs_tys [Type]
arg_kinds
; let arg_reps :: [Type]
arg_reps = forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Type -> Type
kindRep [Type]
arg_kinds
arg_tys :: [Type]
arg_tys = [Type]
arg_reps 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
; HasDebugCallStack =>
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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode) [LHsType GhcRn]
tys
; ([Type]
taus', Type
kind) <- [LHsType GhcRn] -> [(Type, Type)] -> TcM ([Type], Type)
unifyKinds [LHsType GhcRn]
tys [(Type, Type)]
tks
; let ty :: Type
ty = (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')
; HasDebugCallStack =>
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 <- forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
arity TcM Type
newMetaKindVar
; [Type]
taus <- 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]
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
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty (TyCon -> [Type] -> Type
mkTyConApp TyCon
ty_con ([Type]
ks forall a. [a] -> [a] -> [a]
++ [Type]
taus)) Type
tup_k Type
exp_kind }
where
arity :: Arity
arity = forall (t :: * -> *) a. Foldable t => t a -> Arity
length [LHsType GhcRn]
tys
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsIParamTy XIParamTy GhcRn
_ (L SrcSpanAnn' (EpAnn NoEpAnns)
_ HsIPName
n) LHsType GhcRn
ty) Type
exp_kind
= do { 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 forall a b. (a -> b) -> a -> b
$ HsIPName -> FastString
hsIPNameFS HsIPName
n
; Class
ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
; HasDebugCallStack =>
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
= HasDebugCallStack =>
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 XNumTy GhcRn
_ Integer
n)) Type
exp_kind
= do { TyCon -> TcM ()
checkWiredInTyCon TyCon
naturalTyCon
; HasDebugCallStack =>
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 XStrTy GhcRn
_ FastString
s)) Type
exp_kind
= do { TyCon -> TcM ()
checkWiredInTyCon TyCon
typeSymbolKindCon
; HasDebugCallStack =>
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 XCharTy GhcRn
_ Char
c)) Type
exp_kind
= do { TyCon -> TcM ()
checkWiredInTyCon TyCon
charTyCon
; HasDebugCallStack =>
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 = HasDebugCallStack => 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 = HasDebugCallStack => 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 = HasDebugCallStack => 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 = HasDebugCallStack => 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 = HasDebugCallStack => 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 = HasDebugCallStack => 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 { String -> SDoc -> TcM ()
traceTc String
"tc_fun_type" (forall a. Outputable a => a -> SDoc
ppr LHsType GhcRn
ty1 forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr LHsType GhcRn
ty2)
; 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
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy forall a. EpAnn a
noAnn HsArrow GhcRn
mult LHsType GhcRn
ty1 LHsType GhcRn
ty2)
(Type -> Type -> Type -> Type
tcMkVisFunTy 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
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy forall a. EpAnn a
noAnn HsArrow GhcRn
mult LHsType GhcRn
ty1 LHsType GhcRn
ty2)
(Type -> Type -> Type -> Type
tcMkVisFunTy 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
coreView Type
k = Type -> Maybe TupleSort
tupKindSort_maybe Type
k'
| Type -> Bool
isConstraintKind Type
k = forall a. a -> Maybe a
Just TupleSort
ConstraintTuple
| Type -> Bool
tcIsLiftedTypeKind Type
k = forall a. a -> Maybe a
Just TupleSort
BoxedTuple
| Bool
otherwise = 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Arity -> a -> [a]
replicate Arity
arity Type
liftedTypeKind)
TupleSort
UnboxedTuple -> forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
arity TcM Type
newOpenTypeKind
TupleSort
ConstraintTuple -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Arity -> a -> [a]
replicate Arity
arity Type
constraintKind)
; [Type]
tau_tys <- 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]
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 = forall (t :: * -> *) a. Foldable t => t a -> Arity
length [LHsType 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" (forall a. Outputable a => a -> SDoc
ppr TupleSort
tup_sort forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr [Type]
tau_kinds forall doc. IsDoc doc => doc -> doc -> doc
$$ 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 = forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Type -> Type
kindRep [Type]
tau_kinds
arg_tys :: [Type]
arg_tys = [Type]
tau_reps 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 = 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 =
HasDebugCallStack =>
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 = forall a. a -> Maybe a
Just (LHsType GhcRn -> HsTyPats GhcRn -> (LHsType GhcRn, HsTyPats GhcRn)
go (forall a an. a -> LocatedAn an a
noLocA HsType GhcRn
hs_ty) [])
| Bool
otherwise = 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 forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unrestrictedFunTyConKey)
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 (forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcRn
a forall a. a -> [a] -> [a]
: HsTyPats 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 (forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg XAppKindTy GhcRn
l LHsType GhcRn
k forall a. a -> [a] -> [a]
: HsTyPats 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 (forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
sp) forall a. a -> [a] -> [a]
: HsTyPats 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
= ( forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la SrcSpanAnnN
sp) (forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
prom LIdP GhcRn
op)
, forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcRn
l forall a. a -> [a] -> [a]
: forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcRn
r forall a. a -> [a] -> [a]
: HsTyPats 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 {" (forall a. Outputable a => a -> SDoc
ppr LHsType GhcRn
orig_hs_ty forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr HsTyPats 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
orig_hs_args
; String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps }" (forall a. Outputable a => a -> SDoc
ppr Type
f_args forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
res_k)
; 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 -> Subst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n Type
fun Subst
empty_subst Type
fun_ki [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
all_args
where
fun_ki :: Type
fun_ki = HasDebugCallStack => Type -> Type
typeKind Type
fun
empty_subst :: Subst
empty_subst = InScopeSet -> Subst
mkEmptySubst forall a b. (a -> b) -> a -> b
$ TyVarSet -> InScopeSet
mkInScopeSet forall a b. (a -> b) -> a -> b
$
Type -> TyVarSet
tyCoVarsOfType Type
fun_ki
go :: Int
-> TcType
-> Subst
-> TcKind
-> [LHsTypeArg GhcRn]
-> TcM (TcType, TcKind)
go :: Arity
-> Type -> Subst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n Type
fun Subst
subst Type
fun_ki HsTyPats GhcRn
all_args = case (HsTyPats GhcRn
all_args, Type -> Maybe (PiTyBinder, Type)
tcSplitPiTy_maybe Type
fun_ki) of
([], Maybe (PiTyBinder, Type)
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Type
fun, HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst Type
fun_ki)
(HsArgPar SrcSpan
_ : [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
args, Maybe (PiTyBinder, Type)
_) -> Arity
-> Type -> Subst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n Type
fun Subst
subst Type
fun_ki [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 (PiTyBinder
ki_binder, Type
inner_ki)) ->
case PiTyBinder
ki_binder of
Named (Bndr TyVar
_ ForAllTyFlag
Inferred) -> PiTyBinder -> Type -> TcM (Type, Type)
instantiate PiTyBinder
ki_binder Type
inner_ki
Anon Scaled Type
_ FunTyFlag
af | FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af -> PiTyBinder -> Type -> TcM (Type, Type)
instantiate PiTyBinder
ki_binder Type
inner_ki
Named (Bndr TyVar
_ ForAllTyFlag
Specified) ->
do { String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (vis kind app)"
(forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr PiTyBinder
ki_binder, forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ki_arg
, forall a. Outputable a => a -> SDoc
ppr (PiTyBinder -> Type
piTyBinderType PiTyBinder
ki_binder)
, forall a. Outputable a => a -> SDoc
ppr Subst
subst ])
; let exp_kind :: Type
exp_kind = HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst forall a b. (a -> b) -> a -> b
$ PiTyBinder -> Type
piTyBinderType PiTyBinder
ki_binder
; TcTyMode
arg_mode <- TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode TypeOrKind
KindLevel HoleMode
HM_VTA
; Type
ki_arg <- forall a. SDoc -> TcM a -> TcM a
addErrCtxt (forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Arity -> SDoc
funAppCtxt LHsType GhcRn
orig_hs_ty GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ki_arg Arity
n) forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
arg_mode GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ki_arg Type
exp_kind
; String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (vis kind app)" (forall a. Outputable a => a -> SDoc
ppr Type
exp_kind)
; (Subst
subst', Type
fun') <- Subst -> Type -> PiTyBinder -> Type -> TcM (Subst, Type)
mkAppTyM Subst
subst Type
fun PiTyBinder
ki_binder Type
ki_arg
; Arity
-> Type -> Subst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go (Arity
nforall a. Num a => a -> a -> a
+Arity
1) Type
fun' Subst
subst' Type
inner_ki [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
hs_args }
PiTyBinder
_ -> forall {a}. GenLocated SrcSpanAnnA (HsType GhcRn) -> Type -> TcRn a
ty_app_err GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ki_arg forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst Type
fun_ki
(HsTypeArg SrcSpan
_ GenLocated SrcSpanAnnA (HsType GhcRn)
ki_arg : [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
_, Maybe (PiTyBinder, Type)
Nothing) -> TcM (Type, Type) -> TcM (Type, Type)
try_again_after_substing_or forall a b. (a -> b) -> a -> b
$
forall {a}. GenLocated SrcSpanAnnA (HsType GhcRn) -> Type -> 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 (PiTyBinder
ki_binder, Type
inner_ki))
| PiTyBinder -> Bool
isInvisiblePiTyBinder PiTyBinder
ki_binder
-> PiTyBinder -> Type -> TcM (Type, Type)
instantiate PiTyBinder
ki_binder Type
inner_ki
| Bool
otherwise
-> do { String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (vis normal app)"
(forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr PiTyBinder
ki_binder
, forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
arg
, forall a. Outputable a => a -> SDoc
ppr (PiTyBinder -> Type
piTyBinderType PiTyBinder
ki_binder)
, forall a. Outputable a => a -> SDoc
ppr Subst
subst ])
; let exp_kind :: Type
exp_kind = HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst forall a b. (a -> b) -> a -> b
$ PiTyBinder -> Type
piTyBinderType PiTyBinder
ki_binder
; Type
arg' <- forall a. SDoc -> TcM a -> TcM a
addErrCtxt (forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Arity -> SDoc
funAppCtxt LHsType GhcRn
orig_hs_ty GenLocated SrcSpanAnnA (HsType GhcRn)
arg Arity
n) forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode GenLocated SrcSpanAnnA (HsType GhcRn)
arg Type
exp_kind
; String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (vis normal app) 2" (forall a. Outputable a => a -> SDoc
ppr Type
exp_kind)
; (Subst
subst', Type
fun') <- Subst -> Type -> PiTyBinder -> Type -> TcM (Subst, Type)
mkAppTyM Subst
subst Type
fun PiTyBinder
ki_binder Type
arg'
; Arity
-> Type -> Subst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go (Arity
nforall a. Num a => a -> a -> a
+Arity
1) Type
fun' Subst
subst' Type
inner_ki [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 (PiTyBinder, Type)
Nothing)
-> TcM (Type, Type) -> TcM (Type, Type)
try_again_after_substing_or forall a b. (a -> b) -> a -> b
$
do { let arrows_needed :: Arity
arrows_needed = forall tm ty. [HsArg tm ty] -> Arity
n_initial_val_args HsTyPats GhcRn
all_args
; Coercion
co <- TypedThing -> Arity -> Type -> TcM Coercion
matchExpectedFunKind (HsType GhcRn -> TypedThing
HsTypeRnThing forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc LHsType GhcRn
hs_ty) Arity
arrows_needed Type
substed_fun_ki
; Type
fun' <- Type -> TcM Type
zonkTcType (Type
fun Type -> Coercion -> Type
`mkCastTy` Coercion
co)
; String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (no binder)" forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr Type
fun forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
fun_ki
, forall a. Outputable a => a -> SDoc
ppr Arity
arrows_needed
, forall a. Outputable a => a -> SDoc
ppr Coercion
co
, forall a. Outputable a => a -> SDoc
ppr Type
fun' forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
typeKind Type
fun')]
; Arity
-> Type
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcM (Type, Type)
go_init Arity
n Type
fun' HsTyPats GhcRn
all_args }
where
instantiate :: PiTyBinder -> Type -> TcM (Type, Type)
instantiate PiTyBinder
ki_binder Type
inner_ki
= do { String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (need to instantiate)"
(forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr PiTyBinder
ki_binder, forall a. Outputable a => a -> SDoc
ppr Subst
subst])
; (Subst
subst', Type
arg') <- Subst -> PiTyBinder -> TcM (Subst, Type)
tcInstInvisibleTyBinder Subst
subst PiTyBinder
ki_binder
; Arity
-> Type -> Subst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n (Type -> Type -> Type
mkAppTy Type
fun Type
arg') Subst
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 (Subst -> Bool
isEmptyTCvSubst Subst
subst)
= Arity
-> Type -> Subst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n Type
fun Subst
zapped_subst Type
substed_fun_ki HsTyPats GhcRn
all_args
| Bool
otherwise
= TcM (Type, Type)
fallthrough
zapped_subst :: Subst
zapped_subst = Subst -> Subst
zapSubst Subst
subst
substed_fun_ki :: Type
substed_fun_ki = HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst Type
fun_ki
hs_ty :: LHsType GhcRn
hs_ty = LHsType GhcRn -> HsTyPats GhcRn -> LHsType GhcRn
appTypeToArg LHsType GhcRn
orig_hs_ty (forall a. Arity -> [a] -> [a]
take (Arity
nforall a. Num a => a -> a -> a
-Arity
1) HsTyPats 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 forall a. Num a => a -> a -> a
+ forall tm ty. [HsArg tm ty] -> Arity
n_initial_val_args [HsArg tm ty]
args
n_initial_val_args (HsArgPar {} : [HsArg tm ty]
args) = 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 :: GenLocated SrcSpanAnnA (HsType GhcRn) -> Type -> TcRn a
ty_app_err GenLocated SrcSpanAnnA (HsType GhcRn)
arg Type
ty
= forall a. TcRnMessage -> TcM a
failWith forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> Type -> TcRnMessage
TcRnInvalidVisibleKindArgument GenLocated SrcSpanAnnA (HsType GhcRn)
arg Type
ty
mkAppTyM :: Subst
-> TcType -> PiTyBinder
-> TcType
-> TcM (Subst, TcType)
mkAppTyM :: Subst -> Type -> PiTyBinder -> Type -> TcM (Subst, Type)
mkAppTyM Subst
subst Type
fun PiTyBinder
ki_binder Type
arg
|
TyConApp TyCon
tc [Type]
args <- Type
fun
, TyCon -> Bool
isTypeSynonymTyCon TyCon
tc
, [Type]
args forall a. [a] -> Arity -> Bool
`lengthIs` (TyCon -> Arity
tyConArity TyCon
tc forall a. Num a => a -> a -> a
- Arity
1)
, 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' :: Subst
subst' = case PiTyBinder
ki_binder of
Anon {} -> Subst
subst
Named (Bndr TyVar
tv ForAllTyFlag
_) -> Subst -> TyVar -> Type -> Subst
extendTvSubstAndInScope Subst
subst TyVar
tv Type
arg'
; forall (m :: * -> *) a. Monad m => a -> m a
return (Subst
subst', TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ([Type]
args' forall a. [a] -> [a] -> [a]
++ [Type
arg'])) }
mkAppTyM Subst
subst Type
fun (Anon {}) Type
arg
= forall (m :: * -> *) a. Monad m => a -> m a
return (Subst
subst, Type -> Type -> Type
mk_app_ty Type
fun Type
arg)
mkAppTyM Subst
subst Type
fun (Named (Bndr TyVar
tv ForAllTyFlag
_)) Type
arg
= do { Type
arg' <- if TyVar -> Bool
isTrickyTvBinder TyVar
tv
then
Type -> TcM Type
zonkTcType Type
arg
else forall (m :: * -> *) a. Monad m => a -> m a
return Type
arg
; forall (m :: * -> *) a. Monad m => a -> m a
return ( Subst -> TyVar -> Type -> Subst
extendTvSubstAndInScope Subst
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
= forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Type -> Bool
isPiTy Type
fun_kind)
(forall a. Outputable a => a -> SDoc
ppr Type
fun forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
fun_kind forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr Type
arg) forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
mkAppTy Type
fun Type
arg
where
fun_kind :: Type
fun_kind = HasDebugCallStack => Type -> Type
typeKind 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])
tcSplitTyConApp_maybe Type
ty
, TyCon -> Bool
tyConMustBeSaturated TyCon
tc
, let n_to_inst :: Arity
n_to_inst = TyCon -> Arity
tyConArity TyCon
tc forall a. Num a => a -> a -> a
- 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
; forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty Type -> [Type] -> Type
`mkAppTys` [Type]
extra_args, Type
ki') }
| Bool
otherwise
= 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 (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 (forall (p :: Pass).
XAppKindTy (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
mkHsAppKindTy SrcSpan
l LHsType GhcRn
f LHsType GhcRn
arg) HsTyPats GhcRn
args
checkExpectedKind :: HasDebugCallStack
=> HsType GhcRn
-> TcType
-> TcKind
-> TcKind
-> TcM TcType
checkExpectedKind :: HasDebugCallStack =>
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" (forall a. Outputable a => a -> SDoc
ppr Type
ty forall doc. IsDoc doc => doc -> doc -> doc
$$ 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 = 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" forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
hs_ty
, forall doc. IsLine doc => String -> doc
text String
"act_kind':" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
act_kind'
, forall doc. IsLine doc => String -> doc
text String
"exp_kind:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
exp_kind ]
; let res_ty :: Type
res_ty = Type
ty Type -> [Type] -> Type
`mkAppTys` [Type]
new_args
; if Type
act_kind' HasDebugCallStack => Type -> Type -> Bool
`tcEqType` Type
exp_kind
then 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" (forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr Type
act_kind
, forall a. Outputable a => a -> SDoc
ppr Type
exp_kind
, forall a. Outputable a => a -> SDoc
ppr Coercion
co_k ])
; forall (m :: * -> *) a. Monad m => a -> m a
return (Type
res_ty Type -> Coercion -> Type
`mkCastTy` 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 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 = 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcTyMode -> LHsType GhcRn -> TcM Type
tc_lhs_pred TcTyMode
mode) (forall l e. GenLocated l e -> e
unLoc LHsContext 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" (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 -> 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)
-> 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 <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
data_kinds Bool -> Bool -> Bool
|| DataCon -> Bool
specialPromotedDc DataCon
dc) forall a b. (a -> b) -> a -> b
$
forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name PromotionErr
NoDataKindsDC
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isFamInstTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)) forall a b. (a -> b) -> a -> b
$
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" (forall a. Outputable a => a -> SDoc
ppr DataCon
dc forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
theta forall doc. IsDoc doc => doc -> doc -> doc
$$ 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 -> forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name forall a b. (a -> b) -> a -> b
$
Type -> PromotionErr
ConstrainedDataConPE Type
pred
Maybe Type
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
; let tc :: TyCon
tc = DataCon -> TyCon
promoteDataCon DataCon
dc
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [], TyCon -> Type
tyConKind TyCon
tc) }
APromotionErr PromotionErr
err -> forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name PromotionErr
err
TcTyThing
_ -> 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Bool -> Bool
not 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
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
doc TcM a
thing
where
doc :: SDoc
doc = forall doc. IsLine doc => String -> doc
text String
"In the type" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> TcM TyVar
newNamedWildTyVar HsQTvsRn
wc_names
; let wc_prs :: [(Name, TyVar)]
wc_prs = HsQTvsRn
wc_names forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
wcs
; forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
wc_prs forall a b. (a -> b) -> a -> b
$
[(Name, TyVar)] -> TcM a
thing_inside [(Name, TyVar)]
wc_prs }
newNamedWildTyVar :: Name -> TcM TcTyVar
newNamedWildTyVar :: Name -> TcM 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" (forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar)
; 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" (forall a. Outputable a => a -> SDoc
ppr TcLevel
hole_lvl forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Bool
emit_holes)
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
emit_holes forall a b. (a -> b) -> a -> b
$
IsExtraConstraint -> TyVar -> TcM ()
emitAnonTypeHole IsExtraConstraint
is_extra TyVar
wc_tv
; HasDebugCallStack =>
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
_
= forall a. TcRnMessage -> TcM a
failWith forall a b. (a -> b) -> a -> b
$ Maybe Name -> BadAnonWildcardContext -> TcRnMessage
TcRnIllegalWildcardInType forall a. Maybe a
Nothing BadAnonWildcardContext
reason
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) = forall doc. IsLine doc => String -> doc
text String
"SAKS" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
k
ppr SAKS_or_CUSK
CUSK = forall doc. IsLine doc => String -> doc
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
= forall a. Name -> TyConFlavour -> TcM a -> TcM a
addTyConFlavCtxt Name
name TyConFlavour
flav forall a b. (a -> b) -> a -> b
$
do { SkolemInfo
skol_info <- 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)))
<- forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"kcCheckDeclHeader_cusk" forall a b. (a -> b) -> a -> b
$
forall a. SkolemInfo -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Skol SkolemInfo
skol_info XHsQTvs GhcRn
kv_ns forall a b. (a -> b) -> a -> b
$
forall a.
SkolemInfo
-> ContextKind
-> [LHsTyVarBndr () GhcRn]
-> TcM a
-> TcM ([TyVar], a)
bindExplicitTKBndrs_Q_Skol SkolemInfo
skol_info ContextKind
ctxt_kind [LHsTyVarBndr () GhcRn]
hs_tvs forall a b. (a -> b) -> a -> b
$
ContextKind -> TcM Type
newExpectedKind 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 forall a. [a] -> [a] -> [a]
++ [TyVar]
tc_tvs
all_kinds :: [Type]
all_kinds = Type
res_kind forall a. a -> [a] -> [a]
: 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 forall a b. (a -> b) -> a -> b
$
CandidatesQTvs
candidates CandidatesQTvs -> [TyVar] -> CandidatesQTvs
`delCandidates` [TyVar]
spec_req_tkvs
; [TyVar]
scoped_kvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> TcM TyVar
zonkTyCoVarKind [TyVar]
scoped_kvs
; [TyVar]
tc_tvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> TcM 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 = ForAllTyFlag -> [TyVar] -> [TyConBinder]
mkNamedTyConBinders ForAllTyFlag
Inferred [TyVar]
inferred
forall a. [a] -> [a] -> [a]
++ ForAllTyFlag -> [TyVar] -> [TyConBinder]
mkNamedTyConBinders ForAllTyFlag
Specified [TyVar]
specified
forall a. [a] -> [a] -> [a]
++ 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 forall a. [a] -> [a] -> [a]
++ [TyVar]
tc_tvs)
final_tcbs :: [TyConBinder]
final_tcbs = [TyConBinder]
all_tcbs 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 (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 " forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ forall doc. IsLine doc => String -> doc
text String
"name" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Name
name
, forall doc. IsLine doc => String -> doc
text String
"candidates" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr CandidatesQTvs
candidates
, forall doc. IsLine doc => String -> doc
text String
"mentioned_kv_set" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr TyVarSet
mentioned_kv_set
, forall doc. IsLine doc => String -> doc
text String
"kv_ns" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr XHsQTvs GhcRn
kv_ns
, forall doc. IsLine doc => String -> doc
text String
"hs_tvs" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr () GhcRn]
hs_tvs
, forall doc. IsLine doc => String -> doc
text String
"scoped_kvs" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [TyVar]
scoped_kvs
, forall doc. IsLine doc => String -> doc
text String
"spec_req_tvs" forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
spec_req_tkvs
, forall doc. IsLine doc => String -> doc
text String
"all_kinds" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
all_kinds
, forall doc. IsLine doc => String -> doc
text String
"tc_tvs" forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
tc_tvs
, forall doc. IsLine doc => String -> doc
text String
"res_kind" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
res_kind
, forall doc. IsLine doc => String -> doc
text String
"inferred" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [TyVar]
inferred
, forall doc. IsLine doc => String -> doc
text String
"specified" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [TyVar]
specified
, forall doc. IsLine doc => String -> doc
text String
"final_tcbs" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
final_tcbs
, forall doc. IsLine doc => String -> doc
text String
"mkTyConKind final_tc_bndrs res_kind"
forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr ([TyConBinder] -> Type -> Type
mkTyConKind [TyConBinder]
final_tcbs Type
res_kind)
, forall doc. IsLine doc => String -> doc
text String
"all_tv_prs" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
all_tv_prs ]
; 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
= forall a. Name -> TyConFlavour -> TcM a -> TcM a
addTyConFlavCtxt Name
name TyConFlavour
flav forall a b. (a -> b) -> a -> b
$
do { ([TyVar]
scoped_kvs, ([TyVar]
tc_tvs, Type
res_kind))
<- forall a. HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Tv XHsQTvs GhcRn
kv_ns forall a b. (a -> b) -> a -> b
$
forall a.
ContextKind -> [LHsTyVarBndr () GhcRn] -> TcM a -> TcM ([TyVar], a)
bindExplicitTKBndrs_Q_Tv ContextKind
ctxt_kind [LHsTyVarBndr () GhcRn]
hs_tvs forall a b. (a -> b) -> a -> b
$
ContextKind -> TcM Type
newExpectedKind forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TcM ContextKind
kc_res_ki
; let
tc_binders :: [TyConBinder]
tc_binders = [TyVar] -> [TyConBinder]
mkAnonTyConBinders [TyVar]
tc_tvs
all_tv_prs :: [(Name, TyVar)]
all_tv_prs = [TyVar] -> [(Name, TyVar)]
mkTyVarNamePairs ([TyVar]
scoped_kvs 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" forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr Name
name, forall a. Outputable a => a -> SDoc
ppr XHsQTvs GhcRn
kv_ns, forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr () GhcRn]
hs_tvs
, forall a. Outputable a => a -> SDoc
ppr [TyVar]
scoped_kvs
, forall a. Outputable a => a -> SDoc
ppr [TyVar]
tc_tvs, forall a. Outputable a => a -> SDoc
ppr ([TyConBinder] -> Type -> Type
mkTyConKind [TyConBinder]
tc_binders Type
res_kind) ]
; 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
= forall a. Name -> TyConFlavour -> TcM a -> TcM a
addTyConFlavCtxt Name
name TyConFlavour
flav forall a b. (a -> b) -> a -> b
$
do { SkolemInfo
skol_info <- 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
(forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedThing a => a -> OccName
getOccName [LHsTyVarBndr () GhcRn]
hs_tv_bndrs) Type
sig_kind
; String -> SDoc -> TcM ()
traceTc String
"kcCheckDeclHeader_sig {" forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ forall doc. IsLine doc => String -> doc
text String
"sig_kind:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
sig_kind
, forall doc. IsLine doc => String -> doc
text String
"sig_tcbs:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
sig_tcbs
, forall doc. IsLine doc => String -> doc
text String
"sig_res_kind:" forall doc. IsLine doc => doc -> doc -> doc
<+> 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))))
<- forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"kcCheckDeclHeader_sig" forall a b. (a -> b) -> a -> b
$
forall a. HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Tv XHsQTvs GhcRn
implicit_nms forall a b. (a -> b) -> a -> b
$
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 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 = forall a. (a -> Bool) -> [a] -> Arity
countWhile 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 forall a. Ord a => a -> a -> a
`max` (Arity
n_invis_tcbs forall a. Num a => a -> a -> a
- Type -> Arity
invisibleTyBndrCount Type
ki)
; let ([TyConBinder]
invis_tcbs, [TyConBinder]
resid_tcbs) = 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" forall a b. (a -> b) -> a -> b
$ forall doc. IsDoc doc => [doc] -> doc
vcat [ forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
excess_sig_tcbs
, forall a. Outputable a => a -> SDoc
ppr Arity
invis_arity, forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
invis_tcbs
, forall a. Outputable a => a -> SDoc
ppr Arity
n_invis_tcbs ]
; case ContextKind
ctx_k of
ContextKind
AnyKind -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ContextKind
_ -> do { Type
res_ki <- ContextKind -> TcM Type
newExpectedKind ContextKind
ctx_k
; forall a. TcM a -> TcM ()
discardResult (Maybe TypedThing -> Type -> Type -> TcM Coercion
unifyKind forall a. Maybe a
Nothing Type
sig_res_kind' Type
res_ki) }
; if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyConBinder]
resid_tcbs Bool -> Bool -> Bool
|| Bool -> Bool
not (TyConFlavour -> Bool
needsEtaExpansion TyConFlavour
flav)
then forall (m :: * -> *) a. Monad m => a -> m a
return ([TyConBinder]
invis_tcbs, Type
sig_res_kind')
else 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 forall a. [a] -> [a] -> [a]
++ [TyConBinder]
extra_tcbs
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcM ()
reportUnsolvedEqualities SkolemInfo
skol_info (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
all_tcbs) TcLevel
tclvl WantedConstraints
wanted
; [TyVar]
implicit_tvs <- HasDebugCallStack => [TyVar] -> TcM [TyVar]
zonkTcTyVarsToTcTyVars [TyVar]
implicit_tvs
; let implicit_prs :: [(Name, TyVar)]
implicit_prs = XHsQTvs GhcRn
implicit_nms 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 = forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
swap [(Name, TyVar)]
implicit_prs)
(Subst
subst, [TyConBinder]
swizzled_tcbs) = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (VarEnv Name -> Subst -> TyConBinder -> (Subst, TyConBinder)
swizzleTcb VarEnv Name
swizzle_env) Subst
emptySubst [TyConBinder]
all_tcbs
swizzled_kind :: Type
swizzled_kind = HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst Type
tycon_res_kind
all_tv_prs :: [(Name, TyVar)]
all_tv_prs = [TyVar] -> [(Name, TyVar)]
mkTyVarNamePairs (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
swizzled_tcbs)
; String -> SDoc -> TcM ()
traceTc String
"kcCheckDeclHeader swizzle" forall a b. (a -> b) -> a -> b
$ forall doc. IsDoc doc => [doc] -> doc
vcat
[ forall doc. IsLine doc => String -> doc
text String
"implicit_prs = " forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
implicit_prs
, forall doc. IsLine doc => String -> doc
text String
"implicit_nms = " forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr XHsQTvs GhcRn
implicit_nms
, forall doc. IsLine doc => String -> doc
text String
"hs_tv_bndrs = " forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr () GhcRn]
hs_tv_bndrs
, forall doc. IsLine doc => String -> doc
text String
"all_tcbs = " forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
pprTyVars (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
all_tcbs)
, forall doc. IsLine doc => String -> doc
text String
"swizzled_tcbs = " forall doc. IsLine doc => doc -> doc -> doc
<+> [TyVar] -> SDoc
pprTyVars (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
swizzled_tcbs)
, forall doc. IsLine doc => String -> doc
text String
"tycon_res_kind =" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
tycon_res_kind
, forall doc. IsLine doc => String -> doc
text String
"swizzled_kind =" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
swizzled_kind ]
; let tc :: TyCon
tc = Name
-> [TyConBinder]
-> Type
-> [(Name, TyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon Name
name [TyConBinder]
swizzled_tcbs Type
swizzled_kind [(Name, TyVar)]
all_tv_prs Bool
True TyConFlavour
flav
; String -> SDoc -> TcM ()
traceTc String
"kcCheckDeclHeader_sig }" forall a b. (a -> b) -> a -> b
$ forall doc. IsDoc doc => [doc] -> doc
vcat
[ forall doc. IsLine doc => String -> doc
text String
"tyConName = " forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
tc)
, forall doc. IsLine doc => String -> doc
text String
"sig_kind =" forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
debugPprType Type
sig_kind
, forall doc. IsLine doc => String -> doc
text String
"tyConKind =" forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
debugPprType (TyCon -> Type
tyConKind TyCon
tc)
, forall doc. IsLine doc => String -> doc
text String
"tyConBinders = " forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyConBinder]
tyConBinders TyCon
tc)
, forall doc. IsLine doc => String -> doc
text String
"tyConResKind" forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
debugPprType (TyCon -> Type
tyConResKind TyCon
tc)
]
; forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc }
matchUpSigWithDecl
:: [TcTyConBinder]
-> TcKind
-> [LHsTyVarBndr () GhcRn]
-> ([TcTyConBinder] -> TcKind -> TcM a)
-> TcM ( [TcTyConBinder]
, a )
matchUpSigWithDecl :: forall a.
[TyConBinder]
-> Type
-> [LHsTyVarBndr () GhcRn]
-> ([TyConBinder] -> Type -> TcM a)
-> TcM ([TyConBinder], a)
matchUpSigWithDecl [TyConBinder]
sig_tcbs Type
sig_res_kind [LHsTyVarBndr () GhcRn]
hs_bndrs [TyConBinder] -> Type -> TcM a
thing_inside
= Subst
-> [TyConBinder]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> TcM ([TyConBinder], a)
go Subst
emptySubst [TyConBinder]
sig_tcbs [LHsTyVarBndr () GhcRn]
hs_bndrs
where
go :: Subst
-> [TyConBinder]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> TcM ([TyConBinder], a)
go Subst
subst [TyConBinder]
tcbs []
= do { let (Subst
subst', [TyConBinder]
tcbs') = Subst -> [TyConBinder] -> (Subst, [TyConBinder])
substTyConBindersX Subst
subst [TyConBinder]
tcbs
; a
res <- [TyConBinder] -> Type -> TcM a
thing_inside [TyConBinder]
tcbs' (HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst' Type
sig_res_kind)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([], a
res) }
go Subst
_ [] [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
hs_bndrs
= forall a. TcRnMessage -> TcM a
failWithTc (Type -> [LHsTyVarBndr () GhcRn] -> TcRnMessage
TcRnTooManyBinders Type
sig_res_kind [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
hs_bndrs)
go Subst
subst (TyConBinder
tcb : [TyConBinder]
tcbs') [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
hs_bndrs
| Bndr TyVar
tv TyConBndrVis
vis <- TyConBinder
tcb
, TyConBndrVis -> Bool
isVisibleTcbVis TyConBndrVis
vis
, (L SrcSpanAnnA
_ HsTyVarBndr () GhcRn
hs_bndr : [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
hs_bndrs') <- [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
hs_bndrs
=
do { let tv' :: TyVar
tv' = (Type -> Type) -> TyVar -> TyVar
updateTyVarKind (HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst) forall a b. (a -> b) -> a -> b
$
TyVar -> Name -> TyVar
setTyVarName TyVar
tv (forall a. NamedThing a => a -> Name
getName HsTyVarBndr () GhcRn
hs_bndr)
subst' :: Subst
subst' = Subst -> TyVar -> TyVar -> Subst
extendTCvSubstWithClone Subst
subst TyVar
tv TyVar
tv'
; HsTyVarBndr () GhcRn -> Type -> TcM ()
tc_hs_bndr HsTyVarBndr () GhcRn
hs_bndr (TyVar -> Type
tyVarKind TyVar
tv')
; ([TyConBinder]
tcbs', a
res) <- forall r. [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv [TyVar
tv'] forall a b. (a -> b) -> a -> b
$
Subst
-> [TyConBinder]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> TcM ([TyConBinder], a)
go Subst
subst' [TyConBinder]
tcbs' [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
hs_bndrs'
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv' TyConBndrVis
vis forall a. a -> [a] -> [a]
: [TyConBinder]
tcbs', a
res) }
| Bool
otherwise
=
do { let (Subst
subst', TyConBinder
tcb') = Subst -> TyConBinder -> (Subst, TyConBinder)
substTyConBinderX Subst
subst TyConBinder
tcb
; ([TyConBinder]
tcbs', a
res) <- Subst
-> [TyConBinder]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> TcM ([TyConBinder], a)
go Subst
subst' [TyConBinder]
tcbs' [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
hs_bndrs
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyConBinder
tcb' forall a. a -> [a] -> [a]
: [TyConBinder]
tcbs', a
res) }
tc_hs_bndr :: HsTyVarBndr () GhcRn -> TcKind -> TcM ()
tc_hs_bndr :: HsTyVarBndr () GhcRn -> Type -> TcM ()
tc_hs_bndr (UserTyVar XUserTyVar GhcRn
_ ()
_ LIdP GhcRn
_) Type
_
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
tc_hs_bndr (KindedTyVar XKindedTyVar GhcRn
_ ()
_ (L SrcSpanAnnN
_ Name
hs_nm) LHsType GhcRn
lhs_kind) Type
expected_kind
= do { Type
sig_kind <- UserTypeCtxt -> LHsType GhcRn -> TcM Type
tcLHsKindSig (Name -> UserTypeCtxt
TyVarBndrKindCtxt Name
hs_nm) LHsType GhcRn
lhs_kind
; forall a. TcM a -> TcM ()
discardResult forall a b. (a -> b) -> a -> b
$
Maybe TypedThing -> Type -> Type -> TcM Coercion
unifyKind (forall a. a -> Maybe a
Just (Name -> TypedThing
NameThing Name
hs_nm)) Type
sig_kind Type
expected_kind }
substTyConBinderX :: Subst -> TyConBinder -> (Subst, TyConBinder)
substTyConBinderX :: Subst -> TyConBinder -> (Subst, TyConBinder)
substTyConBinderX Subst
subst (Bndr TyVar
tv TyConBndrVis
vis)
= (Subst
subst', forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv' TyConBndrVis
vis)
where
(Subst
subst', TyVar
tv') = HasDebugCallStack => Subst -> TyVar -> (Subst, TyVar)
substTyVarBndr Subst
subst TyVar
tv
substTyConBindersX :: Subst -> [TyConBinder] -> (Subst, [TyConBinder])
substTyConBindersX :: Subst -> [TyConBinder] -> (Subst, [TyConBinder])
substTyConBindersX = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Subst -> TyConBinder -> (Subst, TyConBinder)
substTyConBinderX
swizzleTcb :: VarEnv Name -> Subst -> TyConBinder -> (Subst, TyConBinder)
swizzleTcb :: VarEnv Name -> Subst -> TyConBinder -> (Subst, TyConBinder)
swizzleTcb VarEnv Name
swizzle_env Subst
subst (Bndr TyVar
tv TyConBndrVis
vis)
= (Subst
subst', forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv2 TyConBndrVis
vis)
where
subst' :: Subst
subst' = Subst -> TyVar -> TyVar -> Subst
extendTCvSubstWithClone Subst
subst TyVar
tv TyVar
tv2
tv1 :: TyVar
tv1 = (Type -> Type) -> TyVar -> TyVar
updateTyVarKind (HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst) TyVar
tv
tv2 :: TyVar
tv2 = case forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv VarEnv Name
swizzle_env TyVar
tv of
Just Name
user_name -> TyVar -> Name -> TyVar
setTyVarName TyVar
tv1 Name
user_name
Maybe Name
Nothing -> TyVar
tv1
data ContextKind = TheKind TcKind
| AnyKind
| OpenKind
newExpectedKind :: ContextKind -> TcM TcKind
newExpectedKind :: ContextKind -> TcM Type
newExpectedKind (TheKind Type
k) = forall (m :: * -> *) a. Monad m => a -> m a
return Type
k
newExpectedKind ContextKind
AnyKind = TcM Type
newMetaKindVar
newExpectedKind ContextKind
OpenKind = TcM Type
newOpenTypeKind
expectedKindInCtxt :: UserTypeCtxt -> ContextKind
expectedKindInCtxt :: UserTypeCtxt -> ContextKind
expectedKindInCtxt (TySynCtxt Name
_) = ContextKind
AnyKind
expectedKindInCtxt (GhciCtxt {}) = ContextKind
AnyKind
expectedKindInCtxt UserTypeCtxt
DefaultDeclCtxt = ContextKind
AnyKind
expectedKindInCtxt UserTypeCtxt
DerivClauseCtxt = ContextKind
AnyKind
expectedKindInCtxt UserTypeCtxt
TypeAppCtxt = ContextKind
AnyKind
expectedKindInCtxt (ForSigCtxt Name
_) = Type -> ContextKind
TheKind Type
liftedTypeKind
expectedKindInCtxt (InstDeclCtxt {}) = Type -> ContextKind
TheKind Type
constraintKind
expectedKindInCtxt UserTypeCtxt
SpecInstCtxt = Type -> ContextKind
TheKind Type
constraintKind
expectedKindInCtxt UserTypeCtxt
_ = ContextKind
OpenKind
checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM ()
checkForDuplicateScopedTyVars :: [(Name, TyVar)] -> TcM ()
checkForDuplicateScopedTyVars [(Name, TyVar)]
scoped_prs
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, Name)]
err_prs) forall a b. (a -> b) -> a -> b
$
do { forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, Name) -> TcM ()
report_dup [(Name, Name)]
err_prs; forall env a. IOEnv env a
failM }
where
err_prs :: [(Name,Name)]
err_prs :: [(Name, Name)]
err_prs = [ (Name
n1,Name
n2)
| NonEmpty (Name, TyVar)
prs :: NonEmpty (Name,TyVar) <- forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
findDupsEq (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd) [(Name, TyVar)]
scoped_prs
, (Name
n1,TyVar
_) :| ((Name
n2,TyVar
_) : [(Name, TyVar)]
_) <- [forall a. (a -> a -> Bool) -> NonEmpty a -> NonEmpty a
NE.nubBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) NonEmpty (Name, TyVar)
prs] ]
report_dup :: (Name,Name) -> TcM ()
report_dup :: (Name, Name) -> TcM ()
report_dup (Name
n1,Name
n2)
= forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n2) forall a b. (a -> b) -> a -> b
$
TcRnMessage -> TcM ()
addErrTc forall a b. (a -> b) -> a -> b
$ Name -> Name -> TcRnMessage
TcRnDifferentNamesForTyVar Name
n1 Name
n2
tcTKTelescope :: TcTyMode
-> HsForAllTelescope GhcRn
-> TcM a
-> TcM ([TcTyVarBinder], a)
tcTKTelescope :: forall a.
TcTyMode
-> HsForAllTelescope GhcRn -> TcM a -> TcM ([TcTyVarBinder], a)
tcTKTelescope TcTyMode
mode HsForAllTelescope GhcRn
tele TcM a
thing_inside = case HsForAllTelescope GhcRn
tele of
HsForAllVis { hsf_vis_bndrs :: forall pass. HsForAllTelescope pass -> [LHsTyVarBndr () pass]
hsf_vis_bndrs = [LHsTyVarBndr () GhcRn]
bndrs }
-> do { SkolemInfo
skol_info <- forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (TyVarBndrs -> SkolemInfoAnon
ForAllSkol (forall flag.
OutputableBndrFlag flag 'Renamed =>
[HsTyVarBndr flag GhcRn] -> TyVarBndrs
HsTyVarBndrsRn (forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTyVarBndr () GhcRn]
bndrs)))
; let skol_mode :: SkolemMode
skol_mode = HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_holes :: HoleInfo
sm_holes = TcTyMode -> HoleInfo
mode_holes TcTyMode
mode
, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemInfo -> SkolemModeDetails
SMDSkolemTv SkolemInfo
skol_info }
; ([VarBndr TyVar ()]
req_tv_bndrs, a
thing) <- forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrsX SkolemMode
skol_mode [LHsTyVarBndr () GhcRn]
bndrs TcM a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [VarBndr a ()] -> [VarBndr a ForAllTyFlag]
tyVarReqToBinders [VarBndr TyVar ()]
req_tv_bndrs, a
thing) }
HsForAllInvis { hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity GhcRn]
bndrs }
-> do { SkolemInfo
skol_info <- forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (TyVarBndrs -> SkolemInfoAnon
ForAllSkol (forall flag.
OutputableBndrFlag flag 'Renamed =>
[HsTyVarBndr flag GhcRn] -> TyVarBndrs
HsTyVarBndrsRn (forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTyVarBndr Specificity GhcRn]
bndrs)))
; let skol_mode :: SkolemMode
skol_mode = HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_holes :: HoleInfo
sm_holes = TcTyMode -> HoleInfo
mode_holes TcTyMode
mode
, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemInfo -> SkolemModeDetails
SMDSkolemTv SkolemInfo
skol_info }
; ([VarBndr TyVar Specificity]
inv_tv_bndrs, a
thing) <- forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrsX SkolemMode
skol_mode [LHsTyVarBndr Specificity GhcRn]
bndrs TcM a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [VarBndr a Specificity] -> [VarBndr a ForAllTyFlag]
tyVarSpecToBinders [VarBndr TyVar Specificity]
inv_tv_bndrs, a
thing) }
bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed
=> SkolemMode
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
bindOuterTKBndrsX :: forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
bindOuterTKBndrsX SkolemMode
skol_mode HsOuterTyVarBndrs flag GhcRn
outer_bndrs TcM a
thing_inside
= case HsOuterTyVarBndrs flag GhcRn
outer_bndrs of
HsOuterImplicit{hso_ximplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass
hso_ximplicit = XHsOuterImplicit GhcRn
imp_tvs} ->
do { ([TyVar]
imp_tvs', a
thing) <- forall a. SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrsX SkolemMode
skol_mode XHsOuterImplicit GhcRn
imp_tvs TcM a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsOuterImplicit{hso_ximplicit :: XHsOuterImplicit GhcTc
hso_ximplicit = [TyVar]
imp_tvs'}
, a
thing) }
HsOuterExplicit{hso_bndrs :: forall flag pass.
HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]
hso_bndrs = [LHsTyVarBndr flag (NoGhcTc GhcRn)]
exp_bndrs} ->
do { ([VarBndr TyVar flag]
exp_tvs', a
thing) <- forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrsX SkolemMode
skol_mode [LHsTyVarBndr flag (NoGhcTc GhcRn)]
exp_bndrs TcM a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsOuterExplicit { hso_xexplicit :: XHsOuterExplicit GhcTc flag
hso_xexplicit = [VarBndr TyVar flag]
exp_tvs'
, hso_bndrs :: [LHsTyVarBndr flag (NoGhcTc GhcTc)]
hso_bndrs = [LHsTyVarBndr flag (NoGhcTc GhcRn)]
exp_bndrs }
, a
thing) }
outerTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar]
outerTyVars :: forall flag. HsOuterTyVarBndrs flag GhcTc -> [TyVar]
outerTyVars (HsOuterImplicit { hso_ximplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass
hso_ximplicit = XHsOuterImplicit GhcTc
tvs }) = XHsOuterImplicit GhcTc
tvs
outerTyVars (HsOuterExplicit { hso_xexplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterExplicit pass flag
hso_xexplicit = XHsOuterExplicit GhcTc flag
tvbs }) = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars XHsOuterExplicit GhcTc flag
tvbs
outerTyVarBndrs :: HsOuterTyVarBndrs Specificity GhcTc -> [InvisTVBinder]
outerTyVarBndrs :: HsOuterTyVarBndrs Specificity GhcTc -> [VarBndr TyVar Specificity]
outerTyVarBndrs (HsOuterImplicit{hso_ximplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass
hso_ximplicit = XHsOuterImplicit GhcTc
imp_tvs}) = [forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv Specificity
SpecifiedSpec | TyVar
tv <- XHsOuterImplicit GhcTc
imp_tvs]
outerTyVarBndrs (HsOuterExplicit{hso_xexplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterExplicit pass flag
hso_xexplicit = XHsOuterExplicit GhcTc Specificity
exp_tvs}) = XHsOuterExplicit GhcTc Specificity
exp_tvs
scopedSortOuter :: HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc)
scopedSortOuter :: forall flag.
HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc)
scopedSortOuter (HsOuterImplicit{hso_ximplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass
hso_ximplicit = XHsOuterImplicit GhcTc
imp_tvs})
= do { [TyVar]
imp_tvs <- [TyVar] -> TcM [TyVar]
zonkAndScopedSort XHsOuterImplicit GhcTc
imp_tvs
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsOuterImplicit { hso_ximplicit :: XHsOuterImplicit GhcTc
hso_ximplicit = [TyVar]
imp_tvs }) }
scopedSortOuter bndrs :: HsOuterTyVarBndrs flag GhcTc
bndrs@(HsOuterExplicit{})
=
forall (m :: * -> *) a. Monad m => a -> m a
return HsOuterTyVarBndrs flag GhcTc
bndrs
bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn
-> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)
bindOuterSigTKBndrs_Tv :: forall a.
HsOuterSigTyVarBndrs GhcRn
-> TcM a -> TcM (HsOuterTyVarBndrs Specificity GhcTc, a)
bindOuterSigTKBndrs_Tv
= forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
bindOuterTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
True, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemModeDetails
SMDTyVarTv })
bindOuterSigTKBndrs_Tv_M :: TcTyMode
-> HsOuterSigTyVarBndrs GhcRn
-> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)
bindOuterSigTKBndrs_Tv_M :: forall a.
TcTyMode
-> HsOuterSigTyVarBndrs GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, a)
bindOuterSigTKBndrs_Tv_M TcTyMode
mode
= forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
bindOuterTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
True, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemModeDetails
SMDTyVarTv
, sm_holes :: HoleInfo
sm_holes = TcTyMode -> HoleInfo
mode_holes TcTyMode
mode })
bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn
-> TcM a
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)
bindOuterFamEqnTKBndrs_Q_Tv :: forall a.
HsOuterFamEqnTyVarBndrs GhcRn
-> TcM a -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)
bindOuterFamEqnTKBndrs_Q_Tv HsOuterFamEqnTyVarBndrs GhcRn
hs_bndrs TcM a
thing_inside
= forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
bindOuterTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_parent :: Bool
sm_parent = Bool
True
, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemModeDetails
SMDTyVarTv })
HsOuterFamEqnTyVarBndrs GhcRn
hs_bndrs TcM a
thing_inside
bindOuterFamEqnTKBndrs :: SkolemInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> TcM a
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)
bindOuterFamEqnTKBndrs :: forall a.
SkolemInfo
-> HsOuterFamEqnTyVarBndrs GhcRn
-> TcM a
-> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)
bindOuterFamEqnTKBndrs SkolemInfo
skol_info
= forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
bindOuterTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_parent :: Bool
sm_parent = Bool
True
, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemInfo -> SkolemModeDetails
SMDSkolemTv SkolemInfo
skol_info })
tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed
=> SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrs :: forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrs SkolemInfo
skol_info
= forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False
, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemInfo -> SkolemModeDetails
SMDSkolemTv SkolemInfo
skol_info })
SkolemInfo
skol_info
tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed
=> SkolemMode -> SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrsX :: forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrsX SkolemMode
skol_mode SkolemInfo
skol_info HsOuterTyVarBndrs flag GhcRn
outer_bndrs TcM a
thing_inside
= case HsOuterTyVarBndrs flag GhcRn
outer_bndrs of
HsOuterImplicit{hso_ximplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass
hso_ximplicit = XHsOuterImplicit GhcRn
imp_tvs} ->
do { ([TyVar]
imp_tvs', a
thing) <- forall a.
SkolemMode -> SkolemInfo -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
tcImplicitTKBndrsX SkolemMode
skol_mode SkolemInfo
skol_info XHsOuterImplicit GhcRn
imp_tvs TcM a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsOuterImplicit{hso_ximplicit :: XHsOuterImplicit GhcTc
hso_ximplicit = [TyVar]
imp_tvs'}
, a
thing) }
HsOuterExplicit{hso_bndrs :: forall flag pass.
HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]
hso_bndrs = [LHsTyVarBndr flag (NoGhcTc GhcRn)]
exp_bndrs} ->
do { ([VarBndr TyVar flag]
exp_tvs', a
thing) <- forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrsX SkolemMode
skol_mode [LHsTyVarBndr flag (NoGhcTc GhcRn)]
exp_bndrs TcM a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return ( HsOuterExplicit { hso_xexplicit :: XHsOuterExplicit GhcTc flag
hso_xexplicit = [VarBndr TyVar flag]
exp_tvs'
, hso_bndrs :: [LHsTyVarBndr flag (NoGhcTc GhcTc)]
hso_bndrs = [LHsTyVarBndr flag (NoGhcTc GhcRn)]
exp_bndrs }
, a
thing) }
tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed
=> SkolemInfo
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrs :: forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrs SkolemInfo
skol_info
= forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
True, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemInfo -> SkolemModeDetails
SMDSkolemTv SkolemInfo
skol_info })
tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed
=> SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrsX :: forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrsX SkolemMode
skol_mode [LHsTyVarBndr flag GhcRn]
bndrs TcM a
thing_inside = case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [LHsTyVarBndr flag GhcRn]
bndrs of
Maybe (NonEmpty (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)))
Nothing -> do
{ a
res <- TcM a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return ([], a
res) }
Just NonEmpty (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn))
bndrs1 -> do
{ (TcLevel
tclvl, WantedConstraints
wanted, ([VarBndr TyVar flag]
skol_tvs, a
res))
<- forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints forall a b. (a -> b) -> a -> b
$
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrsX SkolemMode
skol_mode [LHsTyVarBndr flag GhcRn]
bndrs forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
; let bndr_1 :: GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)
bndr_1 = forall a. NonEmpty a -> a
NE.head NonEmpty (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn))
bndrs1; bndr_n :: GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)
bndr_n = forall a. NonEmpty a -> a
NE.last NonEmpty (GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn))
bndrs1
; SkolemInfo
skol_info <- forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (TyVarBndrs -> SkolemInfoAnon
ForAllSkol (forall flag.
OutputableBndrFlag flag 'Renamed =>
[HsTyVarBndr flag GhcRn] -> TyVarBndrs
HsTyVarBndrsRn (forall l e. GenLocated l e -> e
unLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LHsTyVarBndr flag GhcRn]
bndrs)))
; forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)
bndr_1) (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)
bndr_n))
forall a b. (a -> b) -> a -> b
$ SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcM ()
emitResidualTvConstraint SkolemInfo
skol_info (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TyVar flag]
skol_tvs) TcLevel
tclvl WantedConstraints
wanted
; forall (m :: * -> *) a. Monad m => a -> m a
return ([VarBndr TyVar flag]
skol_tvs, a
res) }
bindExplicitTKBndrs_Skol
:: (OutputableBndrFlag flag 'Renamed)
=> SkolemInfo
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrs_Tv
:: (OutputableBndrFlag flag 'Renamed)
=> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrs_Skol :: forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrs_Skol SkolemInfo
skol_info = forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemInfo -> SkolemModeDetails
SMDSkolemTv SkolemInfo
skol_info })
bindExplicitTKBndrs_Tv :: forall flag a.
OutputableBndrFlag flag 'Renamed =>
[LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrs_Tv = forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
True, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemModeDetails
SMDTyVarTv })
bindExplicitTKBndrs_Q_Skol
:: SkolemInfo
-> ContextKind
-> [LHsTyVarBndr () GhcRn]
-> TcM a
-> TcM ([TcTyVar], a)
bindExplicitTKBndrs_Q_Tv
:: ContextKind
-> [LHsTyVarBndr () GhcRn]
-> TcM a
-> TcM ([TcTyVar], a)
bindExplicitTKBndrs_Q_Skol :: forall a.
SkolemInfo
-> ContextKind
-> [LHsTyVarBndr () GhcRn]
-> TcM a
-> TcM ([TyVar], a)
bindExplicitTKBndrs_Q_Skol SkolemInfo
skol_info ContextKind
ctxt_kind [LHsTyVarBndr () GhcRn]
hs_bndrs TcM a
thing_inside
= forall (f :: * -> *) a c b.
Functor f =>
(a -> c) -> f (a, b) -> f (c, b)
mapFst forall tv argf. [VarBndr tv argf] -> [tv]
binderVars forall a b. (a -> b) -> a -> b
$
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_parent :: Bool
sm_parent = Bool
True
, sm_kind :: ContextKind
sm_kind = ContextKind
ctxt_kind, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemInfo -> SkolemModeDetails
SMDSkolemTv SkolemInfo
skol_info })
[LHsTyVarBndr () GhcRn]
hs_bndrs TcM a
thing_inside
bindExplicitTKBndrs_Q_Tv :: forall a.
ContextKind -> [LHsTyVarBndr () GhcRn] -> TcM a -> TcM ([TyVar], a)
bindExplicitTKBndrs_Q_Tv ContextKind
ctxt_kind [LHsTyVarBndr () GhcRn]
hs_bndrs TcM a
thing_inside
= forall (f :: * -> *) a c b.
Functor f =>
(a -> c) -> f (a, b) -> f (c, b)
mapFst forall tv argf. [VarBndr tv argf] -> [tv]
binderVars forall a b. (a -> b) -> a -> b
$
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_parent :: Bool
sm_parent = Bool
True
, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemModeDetails
SMDTyVarTv, sm_kind :: ContextKind
sm_kind = ContextKind
ctxt_kind })
[LHsTyVarBndr () GhcRn]
hs_bndrs TcM a
thing_inside
bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed)
=> SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrsX :: forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrsX skol_mode :: SkolemMode
skol_mode@(SM { sm_parent :: SkolemMode -> Bool
sm_parent = Bool
check_parent, sm_kind :: SkolemMode -> ContextKind
sm_kind = ContextKind
ctxt_kind
, sm_holes :: SkolemMode -> HoleInfo
sm_holes = HoleInfo
hole_info })
[LHsTyVarBndr flag GhcRn]
hs_tvs TcM a
thing_inside
= do { String -> SDoc -> TcM ()
traceTc String
"bindExplicitTKBndrs" (forall a. Outputable a => a -> SDoc
ppr [LHsTyVarBndr flag GhcRn]
hs_tvs)
; [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> TcM ([VarBndr TyVar flag], a)
go [LHsTyVarBndr flag GhcRn]
hs_tvs }
where
tc_ki_mode :: TcTyMode
tc_ki_mode = TcTyMode { mode_tyki :: TypeOrKind
mode_tyki = TypeOrKind
KindLevel, mode_holes :: HoleInfo
mode_holes = HoleInfo
hole_info }
go :: [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> TcM ([VarBndr TyVar flag], a)
go [] = do { a
res <- TcM a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return ([], a
res) }
go (L SrcSpanAnnA
_ HsTyVarBndr flag GhcRn
hs_tv : [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
hs_tvs)
= do { TcTypeEnv
lcl_env <- TcM TcTypeEnv
getLclTypeEnv
; TyVar
tv <- TcTypeEnv -> HsTyVarBndr flag GhcRn -> TcM TyVar
tc_hs_bndr TcTypeEnv
lcl_env HsTyVarBndr flag GhcRn
hs_tv
; ([VarBndr TyVar flag]
tvs,a
res) <- forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(forall flag (p :: Pass).
HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsTyVarName HsTyVarBndr flag GhcRn
hs_tv, TyVar
tv)] forall a b. (a -> b) -> a -> b
$
[GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> TcM ([VarBndr TyVar flag], a)
go [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
hs_tvs
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv (forall flag (pass :: Pass). HsTyVarBndr flag (GhcPass pass) -> flag
hsTyVarBndrFlag HsTyVarBndr flag GhcRn
hs_tv)forall a. a -> [a] -> [a]
:[VarBndr TyVar flag]
tvs, a
res) }
tc_hs_bndr :: TcTypeEnv -> HsTyVarBndr flag GhcRn -> TcM TyVar
tc_hs_bndr TcTypeEnv
lcl_env (UserTyVar XUserTyVar GhcRn
_ flag
_ (L Anno (IdGhcP 'Renamed)
_ Name
name))
| Bool
check_parent
, Just (ATyVar Name
_ TyVar
tv) <- forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
lcl_env Name
name
= forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
tv
| Bool
otherwise
= do { Type
kind <- ContextKind -> TcM Type
newExpectedKind ContextKind
ctxt_kind
; SkolemMode -> Name -> Type -> TcM TyVar
newTyVarBndr SkolemMode
skol_mode Name
name Type
kind }
tc_hs_bndr TcTypeEnv
lcl_env (KindedTyVar XKindedTyVar GhcRn
_ flag
_ (L Anno (IdGhcP 'Renamed)
_ Name
name) LHsType GhcRn
lhs_kind)
| Bool
check_parent
, Just (ATyVar Name
_ TyVar
tv) <- forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
lcl_env Name
name
= do { Type
kind <- TcTyMode -> UserTypeCtxt -> LHsType GhcRn -> TcM Type
tc_lhs_kind_sig TcTyMode
tc_ki_mode (Name -> UserTypeCtxt
TyVarBndrKindCtxt Name
name) LHsType GhcRn
lhs_kind
; forall a. TcM a -> TcM ()
discardResult forall a b. (a -> b) -> a -> b
$
Maybe TypedThing -> Type -> Type -> TcM Coercion
unifyKind (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> TypedThing
NameThing forall a b. (a -> b) -> a -> b
$ Name
name) Type
kind (TyVar -> Type
tyVarKind TyVar
tv)
; forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
tv }
| Bool
otherwise
= do { Type
kind <- TcTyMode -> UserTypeCtxt -> LHsType GhcRn -> TcM Type
tc_lhs_kind_sig TcTyMode
tc_ki_mode (Name -> UserTypeCtxt
TyVarBndrKindCtxt Name
name) LHsType GhcRn
lhs_kind
; SkolemMode -> Name -> Type -> TcM TyVar
newTyVarBndr SkolemMode
skol_mode Name
name Type
kind }
newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar
newTyVarBndr :: SkolemMode -> Name -> Type -> TcM TyVar
newTyVarBndr (SM { sm_clone :: SkolemMode -> Bool
sm_clone = Bool
clone, sm_tvtv :: SkolemMode -> SkolemModeDetails
sm_tvtv = SkolemModeDetails
tvtv }) Name
name Type
kind
= do { Name
name <- case Bool
clone of
Bool
True -> do { Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Unique -> Name
setNameUnique Name
name Unique
uniq) }
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
; TcTyVarDetails
details <- case SkolemModeDetails
tvtv of
SkolemModeDetails
SMDTyVarTv -> MetaInfo -> TcM TcTyVarDetails
newMetaDetails MetaInfo
TyVarTv
SMDSkolemTv SkolemInfo
skol_info ->
do { TcLevel
lvl <- TcM TcLevel
getTcLevel
; forall (m :: * -> *) a. Monad m => a -> m a
return (SkolemInfo -> TcLevel -> Bool -> TcTyVarDetails
SkolemTv SkolemInfo
skol_info TcLevel
lvl Bool
False) }
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type -> TcTyVarDetails -> TyVar
mkTcTyVar Name
name Type
kind TcTyVarDetails
details) }
tcImplicitTKBndrsX :: SkolemMode -> SkolemInfo
-> [Name]
-> TcM a
-> TcM ([TcTyVar], a)
tcImplicitTKBndrsX :: forall a.
SkolemMode -> SkolemInfo -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
tcImplicitTKBndrsX SkolemMode
skol_mode SkolemInfo
skol_info HsQTvsRn
bndrs TcM a
thing_inside
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null HsQTvsRn
bndrs
= do { a
res <- TcM a
thing_inside; forall (m :: * -> *) a. Monad m => a -> m a
return ([], a
res) }
| Bool
otherwise
= do { (TcLevel
tclvl, WantedConstraints
wanted, ([TyVar]
skol_tvs, a
res))
<- forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints forall a b. (a -> b) -> a -> b
$
forall a. SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrsX SkolemMode
skol_mode HsQTvsRn
bndrs forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcM ()
emitResidualTvConstraint SkolemInfo
skol_info [TyVar]
skol_tvs TcLevel
tclvl WantedConstraints
wanted
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
skol_tvs, a
res) }
bindImplicitTKBndrs_Skol,
bindImplicitTKBndrs_Q_Skol :: SkolemInfo -> [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Q_Tv :: [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Skol :: forall a. SkolemInfo -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Skol SkolemInfo
skol_info = forall a. SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
True, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemInfo -> SkolemModeDetails
SMDSkolemTv SkolemInfo
skol_info })
bindImplicitTKBndrs_Tv :: forall a. HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Tv = forall a. SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
True, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemModeDetails
SMDTyVarTv })
bindImplicitTKBndrs_Q_Skol :: forall a. SkolemInfo -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Skol SkolemInfo
skol_info = forall a. SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_parent :: Bool
sm_parent = Bool
True, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemInfo -> SkolemModeDetails
SMDSkolemTv SkolemInfo
skol_info })
bindImplicitTKBndrs_Q_Tv :: forall a. HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Tv = forall a. SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrsX (HasCallStack => SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_parent :: Bool
sm_parent = Bool
True, sm_tvtv :: SkolemModeDetails
sm_tvtv = SkolemModeDetails
SMDTyVarTv })
bindImplicitTKBndrsX
:: SkolemMode
-> [Name]
-> TcM a
-> TcM ([TcTyVar], a)
bindImplicitTKBndrsX :: forall a. SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrsX skol_mode :: SkolemMode
skol_mode@(SM { sm_parent :: SkolemMode -> Bool
sm_parent = Bool
check_parent, sm_kind :: SkolemMode -> ContextKind
sm_kind = ContextKind
ctxt_kind })
HsQTvsRn
tv_names TcM a
thing_inside
= do { TcTypeEnv
lcl_env <- TcM TcTypeEnv
getLclTypeEnv
; [TyVar]
tkvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcTypeEnv -> Name -> TcM TyVar
new_tv TcTypeEnv
lcl_env) HsQTvsRn
tv_names
; String -> SDoc -> TcM ()
traceTc String
"bindImplicitTKBndrsX" (forall a. Outputable a => a -> SDoc
ppr HsQTvsRn
tv_names forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr [TyVar]
tkvs)
; a
res <- forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (HsQTvsRn
tv_names forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
tkvs)
TcM a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
tkvs, a
res) }
where
new_tv :: TcTypeEnv -> Name -> TcM TyVar
new_tv TcTypeEnv
lcl_env Name
name
| Bool
check_parent
, Just (ATyVar Name
_ TyVar
tv) <- forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
lcl_env Name
name
= forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
tv
| Bool
otherwise
= do { Type
kind <- ContextKind -> TcM Type
newExpectedKind ContextKind
ctxt_kind
; SkolemMode -> Name -> Type -> TcM TyVar
newTyVarBndr SkolemMode
skol_mode Name
name Type
kind }
data SkolemMode
= SM { SkolemMode -> Bool
sm_parent :: Bool
, SkolemMode -> Bool
sm_clone :: Bool
, SkolemMode -> SkolemModeDetails
sm_tvtv :: SkolemModeDetails
, SkolemMode -> ContextKind
sm_kind :: ContextKind
, SkolemMode -> HoleInfo
sm_holes :: HoleInfo
}
data SkolemModeDetails
= SMDTyVarTv
| SMDSkolemTv SkolemInfo
smVanilla :: HasCallStack => SkolemMode
smVanilla :: HasCallStack => SkolemMode
smVanilla = SM { sm_clone :: Bool
sm_clone = forall a. HasCallStack => String -> a
panic String
"sm_clone"
, sm_parent :: Bool
sm_parent = Bool
False
, sm_tvtv :: SkolemModeDetails
sm_tvtv = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"sm_tvtv" HasCallStack => SDoc
callStackDoc
, sm_kind :: ContextKind
sm_kind = ContextKind
AnyKind
, sm_holes :: HoleInfo
sm_holes = forall a. Maybe a
Nothing }
bindTyClTyVars :: Name -> ([TcTyConBinder] -> TcKind -> TcM a) -> TcM a
bindTyClTyVars :: forall a. Name -> ([TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tycon_name [TyConBinder] -> Type -> TcM a
thing_inside
= do { TyCon
tycon <- HasDebugCallStack => Name -> TcM TyCon
tcLookupTcTyCon Name
tycon_name
; let res_kind :: Type
res_kind = TyCon -> Type
tyConResKind TyCon
tycon
binders :: [TyConBinder]
binders = TyCon -> [TyConBinder]
tyConBinders TyCon
tycon
; String -> SDoc -> TcM ()
traceTc String
"bindTyClTyVars" (forall a. Outputable a => a -> SDoc
ppr Name
tycon_name forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
binders)
; forall r. [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv (forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
binders) forall a b. (a -> b) -> a -> b
$
[TyConBinder] -> Type -> TcM a
thing_inside [TyConBinder]
binders Type
res_kind }
bindTyClTyVarsAndZonk :: Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
bindTyClTyVarsAndZonk :: forall a. Name -> ([TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVarsAndZonk Name
tycon_name [TyConBinder] -> Type -> TcM a
thing_inside
= forall a. Name -> ([TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tycon_name forall a b. (a -> b) -> a -> b
$ \ [TyConBinder]
tc_bndrs Type
tc_kind ->
do { ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; (ZonkEnv
ze, [TyConBinder]
bndrs) <- forall vis.
ZonkEnv
-> [VarBndr TyVar vis] -> TcM (ZonkEnv, [VarBndr TyVar vis])
zonkTyVarBindersX ZonkEnv
ze [TyConBinder]
tc_bndrs
; Type
kind <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze Type
tc_kind
; [TyConBinder] -> Type -> TcM a
thing_inside [TyConBinder]
bndrs Type
kind }
zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]
zonkAndScopedSort :: [TyVar] -> TcM [TyVar]
zonkAndScopedSort [TyVar]
spec_tkvs
= do { [TyVar]
spec_tkvs <- HasDebugCallStack => [TyVar] -> TcM [TyVar]
zonkTcTyVarsToTcTyVars [TyVar]
spec_tkvs
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar] -> [TyVar]
scopedSort [TyVar]
spec_tkvs) }
kindGeneralizeSome :: SkolemInfo
-> WantedConstraints
-> TcType
-> TcM [KindVar]
kindGeneralizeSome :: SkolemInfo -> WantedConstraints -> Type -> TcM [TyVar]
kindGeneralizeSome SkolemInfo
skol_info WantedConstraints
wanted Type
kind_or_type
= do {
; CandidatesQTvs
dvs <- Type -> TcM CandidatesQTvs
candidateQTyVarsOfKind Type
kind_or_type
; CandidatesQTvs
dvs <- WantedConstraints -> CandidatesQTvs -> TcM CandidatesQTvs
filterConstrainedCandidates WantedConstraints
wanted CandidatesQTvs
dvs
; SkolemInfo
-> NonStandardDefaultingStrategy -> CandidatesQTvs -> TcM [TyVar]
quantifyTyVars SkolemInfo
skol_info NonStandardDefaultingStrategy
DefaultNonStandardTyVars CandidatesQTvs
dvs }
filterConstrainedCandidates
:: WantedConstraints
-> CandidatesQTvs
-> TcM CandidatesQTvs
filterConstrainedCandidates :: WantedConstraints -> CandidatesQTvs -> TcM CandidatesQTvs
filterConstrainedCandidates WantedConstraints
wanted CandidatesQTvs
dvs
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wanted
= forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dvs
| Bool
otherwise
= do { TyVarSet
wc_tvs <- TyVarSet -> TcM TyVarSet
zonkTyCoVarsAndFV (WantedConstraints -> TyVarSet
tyCoVarsOfWC WantedConstraints
wanted)
; let (TyVarSet
to_promote, CandidatesQTvs
dvs') = CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs)
partitionCandidates CandidatesQTvs
dvs (TyVar -> TyVarSet -> Bool
`elemVarSet` TyVarSet
wc_tvs)
; Bool
_ <- TyVarSet -> TcM Bool
promoteTyVarSet TyVarSet
to_promote
; forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dvs' }
kindGeneralizeAll :: SkolemInfo -> TcType -> TcM [KindVar]
kindGeneralizeAll :: SkolemInfo -> Type -> TcM [TyVar]
kindGeneralizeAll SkolemInfo
skol_info Type
kind_or_type
= do { String -> SDoc -> TcM ()
traceTc String
"kindGeneralizeAll" (forall a. Outputable a => a -> SDoc
ppr Type
kind_or_type)
; CandidatesQTvs
dvs <- Type -> TcM CandidatesQTvs
candidateQTyVarsOfKind Type
kind_or_type
; SkolemInfo
-> NonStandardDefaultingStrategy -> CandidatesQTvs -> TcM [TyVar]
quantifyTyVars SkolemInfo
skol_info NonStandardDefaultingStrategy
DefaultNonStandardTyVars CandidatesQTvs
dvs }
kindGeneralizeNone :: TcType
-> TcM ()
kindGeneralizeNone :: Type -> TcM ()
kindGeneralizeNone Type
kind_or_type
= do { String -> SDoc -> TcM ()
traceTc String
"kindGeneralizeNone" (forall a. Outputable a => a -> SDoc
ppr Type
kind_or_type)
; CandidatesQTvs
dvs <- Type -> TcM CandidatesQTvs
candidateQTyVarsOfKind Type
kind_or_type
; Bool
_ <- TyVarSet -> TcM Bool
promoteTyVarSet (CandidatesQTvs -> TyVarSet
candidateKindVars CandidatesQTvs
dvs)
; forall (m :: * -> *) a. Monad m => a -> m a
return () }
etaExpandAlgTyCon :: TyConFlavour -> SkolemInfo
-> [TcTyConBinder] -> Kind
-> TcM ([TcTyConBinder], Kind)
etaExpandAlgTyCon :: TyConFlavour
-> SkolemInfo -> [TyConBinder] -> Type -> TcM ([TyConBinder], Type)
etaExpandAlgTyCon TyConFlavour
flav SkolemInfo
skol_info [TyConBinder]
tcbs Type
res_kind
| TyConFlavour -> Bool
needsEtaExpansion TyConFlavour
flav
= SkolemInfo
-> InScopeSet -> [OccName] -> Type -> TcM ([TyConBinder], Type)
splitTyConKind SkolemInfo
skol_info InScopeSet
in_scope [OccName]
avoid_occs Type
res_kind
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ([], Type
res_kind)
where
tyvars :: [TyVar]
tyvars = forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tcbs
in_scope :: InScopeSet
in_scope = [TyVar] -> InScopeSet
mkInScopeSetList [TyVar]
tyvars
avoid_occs :: [OccName]
avoid_occs = forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedThing a => a -> OccName
getOccName [TyVar]
tyvars
needsEtaExpansion :: TyConFlavour -> Bool
needsEtaExpansion :: TyConFlavour -> Bool
needsEtaExpansion TyConFlavour
NewtypeFlavour = Bool
True
needsEtaExpansion TyConFlavour
DataTypeFlavour = Bool
True
needsEtaExpansion TyConFlavour
ClassFlavour = Bool
True
needsEtaExpansion TyConFlavour
_ = Bool
False
splitTyConKind :: SkolemInfo
-> InScopeSet
-> [OccName]
-> Kind
-> TcM ([TcTyConBinder], TcKind)
splitTyConKind :: SkolemInfo
-> InScopeSet -> [OccName] -> Type -> TcM ([TyConBinder], Type)
splitTyConKind SkolemInfo
skol_info InScopeSet
in_scope [OccName]
avoid_occs Type
kind
= do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; UniqSupply
uniqs <- forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
; LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
; TcLevel
lvl <- TcM TcLevel
getTcLevel
; let new_occs :: Infinite OccName
new_occs = forall a. (a -> Bool) -> Infinite a -> Infinite a
Inf.filter (\ OccName
occ ->
forall a. Maybe a -> Bool
isNothing (LocalRdrEnv -> OccName -> Maybe Name
lookupLocalRdrOcc LocalRdrEnv
rdr_env OccName
occ) Bool -> Bool -> Bool
&&
Bool -> Bool
not (OccName
occ forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OccName]
avoid_occs)) forall a b. (a -> b) -> a -> b
$ NameSpace -> String -> OccName
mkOccName NameSpace
tvName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Infinite String
allNameStrings
new_uniqs :: [Unique]
new_uniqs = UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
uniqs
subst :: Subst
subst = InScopeSet -> Subst
mkEmptySubst InScopeSet
in_scope
details :: TcTyVarDetails
details = SkolemInfo -> TcLevel -> Bool -> TcTyVarDetails
SkolemTv SkolemInfo
skol_info (TcLevel -> TcLevel
pushTcLevel TcLevel
lvl) Bool
False
go :: Infinite OccName
-> [Unique]
-> Subst
-> [TyConBinder]
-> Type
-> ([TyConBinder], Type)
go Infinite OccName
occs [Unique]
uniqs Subst
subst [TyConBinder]
acc Type
kind
= case Type -> Maybe (PiTyBinder, Type)
splitPiTy_maybe Type
kind of
Maybe (PiTyBinder, Type)
Nothing -> (forall a. [a] -> [a]
reverse [TyConBinder]
acc, HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst Type
kind)
Just (Anon Scaled Type
arg FunTyFlag
af, Type
kind')
-> Infinite OccName
-> [Unique]
-> Subst
-> [TyConBinder]
-> Type
-> ([TyConBinder], Type)
go Infinite OccName
occs' [Unique]
uniqs' Subst
subst' (TyConBinder
tcb forall a. a -> [a] -> [a]
: [TyConBinder]
acc) Type
kind'
where
tcb :: TyConBinder
tcb = forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv (FunTyFlag -> TyConBndrVis
AnonTCB FunTyFlag
af)
arg' :: Type
arg' = HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst (forall a. Scaled a -> a
scaledThing Scaled Type
arg)
name :: Name
name = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
loc
tv :: TyVar
tv = Name -> Type -> TcTyVarDetails -> TyVar
mkTcTyVar Name
name Type
arg' TcTyVarDetails
details
subst' :: Subst
subst' = Subst -> TyVar -> Subst
extendSubstInScope Subst
subst TyVar
tv
Unique
uniq:[Unique]
uniqs' = [Unique]
uniqs
Inf OccName
occ Infinite OccName
occs' = Infinite OccName
occs
Just (Named (Bndr TyVar
tv ForAllTyFlag
vis), Type
kind')
-> Infinite OccName
-> [Unique]
-> Subst
-> [TyConBinder]
-> Type
-> ([TyConBinder], Type)
go Infinite OccName
occs [Unique]
uniqs Subst
subst' (TyConBinder
tcb forall a. a -> [a] -> [a]
: [TyConBinder]
acc) Type
kind'
where
tcb :: TyConBinder
tcb = forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv' (ForAllTyFlag -> TyConBndrVis
NamedTCB ForAllTyFlag
vis)
tc_tyvar :: TyVar
tc_tyvar = Name -> Type -> TcTyVarDetails -> TyVar
mkTcTyVar (TyVar -> Name
tyVarName TyVar
tv) (TyVar -> Type
tyVarKind TyVar
tv) TcTyVarDetails
details
(Subst
subst', TyVar
tv') = HasDebugCallStack => Subst -> TyVar -> (Subst, TyVar)
substTyVarBndr Subst
subst TyVar
tc_tyvar
; forall (m :: * -> *) a. Monad m => a -> m a
return (Infinite OccName
-> [Unique]
-> Subst
-> [TyConBinder]
-> Type
-> ([TyConBinder], Type)
go Infinite OccName
new_occs [Unique]
new_uniqs Subst
subst [] Type
kind) }
isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool
isAllowedDataResKind :: AllowedDataResKind -> Type -> Bool
isAllowedDataResKind AllowedDataResKind
AnyTYPEKind Type
kind = Type -> Bool
isTypeLikeKind Type
kind
isAllowedDataResKind AllowedDataResKind
AnyBoxedKind Type
kind = Type -> Bool
tcIsBoxedTypeKind Type
kind
isAllowedDataResKind AllowedDataResKind
LiftedKind Type
kind = Type -> Bool
tcIsLiftedTypeKind Type
kind
checkDataKindSig :: DataSort -> Kind
-> TcM ()
checkDataKindSig :: DataSort -> Type -> TcM ()
checkDataKindSig DataSort
data_sort Type
kind
= do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; String -> SDoc -> TcM ()
traceTc String
"checkDataKindSig" (forall a. Outputable a => a -> SDoc
ppr Type
kind)
; Bool -> TcRnMessage -> TcM ()
checkTc (DynFlags -> Bool
tYPE_ok DynFlags
dflags Bool -> Bool -> Bool
|| Bool
is_kind_var)
(DynFlags -> TcRnMessage
err_msg DynFlags
dflags) }
where
res_kind :: Type
res_kind = forall a b. (a, b) -> b
snd (Type -> ([PiTyBinder], Type)
tcSplitPiTys Type
kind)
is_newtype :: Bool
is_newtype :: Bool
is_newtype =
case DataSort
data_sort of
DataDeclSort NewOrData
new_or_data -> NewOrData
new_or_data forall a. Eq a => a -> a -> Bool
== NewOrData
NewType
DataInstanceSort NewOrData
new_or_data -> NewOrData
new_or_data forall a. Eq a => a -> a -> Bool
== NewOrData
NewType
DataSort
DataFamilySort -> Bool
False
is_datatype :: Bool
is_datatype :: Bool
is_datatype =
case DataSort
data_sort of
DataDeclSort NewOrData
DataType -> Bool
True
DataInstanceSort NewOrData
DataType -> Bool
True
DataSort
_ -> Bool
False
is_data_family :: Bool
is_data_family :: Bool
is_data_family =
case DataSort
data_sort of
DataDeclSort{} -> Bool
False
DataInstanceSort{} -> Bool
False
DataSort
DataFamilySort -> Bool
True
allowed_kind :: DynFlags -> AllowedDataResKind
allowed_kind :: DynFlags -> AllowedDataResKind
allowed_kind DynFlags
dflags
| Bool
is_newtype Bool -> Bool -> Bool
&& Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnliftedNewtypes DynFlags
dflags
= AllowedDataResKind
AnyTYPEKind
| Bool
is_data_family
= AllowedDataResKind
AnyTYPEKind
| Bool
is_datatype Bool -> Bool -> Bool
&& Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnliftedDatatypes DynFlags
dflags
= AllowedDataResKind
AnyBoxedKind
| Bool
otherwise
= AllowedDataResKind
LiftedKind
tYPE_ok :: DynFlags -> Bool
tYPE_ok :: DynFlags -> Bool
tYPE_ok DynFlags
dflags = AllowedDataResKind -> Type -> Bool
isAllowedDataResKind (DynFlags -> AllowedDataResKind
allowed_kind DynFlags
dflags) Type
res_kind
is_kind_var :: Bool
is_kind_var :: Bool
is_kind_var | Bool
is_data_family = forall a. Maybe a -> Bool
isJust (Type -> Maybe (TyVar, Coercion)
getCastedTyVar_maybe Type
res_kind)
| Bool
otherwise = Bool
False
err_msg :: DynFlags -> TcRnMessage
err_msg :: DynFlags -> TcRnMessage
err_msg DynFlags
dflags =
DataSort
-> AllowedDataResKind
-> Type
-> Maybe SuggestUnliftedTypes
-> TcRnMessage
TcRnInvalidReturnKind DataSort
data_sort (DynFlags -> AllowedDataResKind
allowed_kind DynFlags
dflags) Type
kind (DynFlags -> Maybe SuggestUnliftedTypes
ext_hint DynFlags
dflags)
ext_hint :: DynFlags -> Maybe SuggestUnliftedTypes
ext_hint DynFlags
dflags
| Type -> Bool
isTypeLikeKind Type
kind
, Bool
is_newtype
, Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnliftedNewtypes DynFlags
dflags)
= forall a. a -> Maybe a
Just SuggestUnliftedTypes
SuggestUnliftedNewtypes
| Type -> Bool
tcIsBoxedTypeKind Type
kind
, Bool
is_datatype
, Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnliftedDatatypes DynFlags
dflags)
= forall a. a -> Maybe a
Just SuggestUnliftedTypes
SuggestUnliftedDatatypes
| Bool
otherwise
= forall a. Maybe a
Nothing
checkClassKindSig :: Kind -> TcM ()
checkClassKindSig :: Type -> TcM ()
checkClassKindSig Type
kind = Bool -> TcRnMessage -> TcM ()
checkTc (Type -> Bool
isConstraintKind Type
kind) TcRnMessage
err_msg
where
err_msg :: TcRnMessage
err_msg :: TcRnMessage
err_msg = Type -> TcRnMessage
TcRnClassKindNotConstraint Type
kind
tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]
tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]
tcbVisibilities TyCon
tc [Type]
orig_args
= Type -> Subst -> [Type] -> [TyConBndrVis]
go (TyCon -> Type
tyConKind TyCon
tc) Subst
init_subst [Type]
orig_args
where
init_subst :: Subst
init_subst = InScopeSet -> Subst
mkEmptySubst (TyVarSet -> InScopeSet
mkInScopeSet ([Type] -> TyVarSet
tyCoVarsOfTypes [Type]
orig_args))
go :: Type -> Subst -> [Type] -> [TyConBndrVis]
go Type
_ Subst
_ []
= []
go Type
fun_kind Subst
subst all_args :: [Type]
all_args@(Type
arg : [Type]
args)
| Just (PiTyBinder
tcb, Type
inner_kind) <- Type -> Maybe (PiTyBinder, Type)
splitPiTy_maybe Type
fun_kind
= case PiTyBinder
tcb of
Anon Scaled Type
_ FunTyFlag
af -> FunTyFlag -> TyConBndrVis
AnonTCB FunTyFlag
af forall a. a -> [a] -> [a]
: Type -> Subst -> [Type] -> [TyConBndrVis]
go Type
inner_kind Subst
subst [Type]
args
Named (Bndr TyVar
tv ForAllTyFlag
vis) -> ForAllTyFlag -> TyConBndrVis
NamedTCB ForAllTyFlag
vis forall a. a -> [a] -> [a]
: Type -> Subst -> [Type] -> [TyConBndrVis]
go Type
inner_kind Subst
subst' [Type]
args
where
subst' :: Subst
subst' = Subst -> TyVar -> Type -> Subst
extendTCvSubst Subst
subst TyVar
tv Type
arg
| Bool -> Bool
not (Subst -> Bool
isEmptyTCvSubst Subst
subst)
= Type -> Subst -> [Type] -> [TyConBndrVis]
go (HasDebugCallStack => Subst -> Type -> Type
substTy Subst
subst Type
fun_kind) Subst
init_subst [Type]
all_args
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"addTcbVisibilities" (forall a. Outputable a => a -> SDoc
ppr TyCon
tc forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
orig_args)
tcHsPartialSigType
:: UserTypeCtxt
-> LHsSigWcType GhcRn
-> TcM ( [(Name, TcTyVar)]
, Maybe TcType
, [(Name,InvisTVBinder)]
, TcThetaType
, TcType )
tcHsPartialSigType :: UserTypeCtxt
-> LHsSigWcType GhcRn
-> TcM
([(Name, TyVar)], Maybe Type, [(Name, VarBndr TyVar Specificity)],
[Type], Type)
tcHsPartialSigType UserTypeCtxt
ctxt LHsSigWcType GhcRn
sig_ty
| HsWC { hswc_ext :: forall pass thing. HsWildCardBndrs pass thing -> XHsWC pass thing
hswc_ext = XHsWC GhcRn (LHsSigType GhcRn)
sig_wcs, hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = LHsSigType GhcRn
sig_ty } <- LHsSigWcType 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
body_ty}) <- LHsSigType GhcRn
sig_ty
, (Maybe (LHsContext GhcRn)
hs_ctxt, LHsType GhcRn
hs_tau) <- forall (pass :: Pass).
LHsType (GhcPass pass)
-> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsQualTy LHsType GhcRn
body_ty
= forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt LHsSigType GhcRn
sig_ty forall a b. (a -> b) -> a -> b
$
do { TcTyMode
mode <- TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode TypeOrKind
TypeLevel HoleMode
HM_Sig
; (HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs, ([(Name, TyVar)]
wcs, Maybe Type
wcx, [Type]
theta, Type
tau))
<- forall a. String -> TcM a -> TcM a
solveEqualities String
"tcHsPartialSigType" forall a b. (a -> b) -> a -> b
$
forall a. HsQTvsRn -> ([(Name, TyVar)] -> TcM a) -> TcM a
bindNamedWildCardBinders XHsWC GhcRn (LHsSigType GhcRn)
sig_wcs forall a b. (a -> b) -> a -> b
$ \ [(Name, TyVar)]
wcs ->
forall a.
TcTyMode
-> HsOuterSigTyVarBndrs GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, a)
bindOuterSigTKBndrs_Tv_M TcTyMode
mode HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs forall a b. (a -> b) -> a -> b
$
do {
([Type]
theta, Maybe Type
wcx) <- TcTyMode -> Maybe (LHsContext GhcRn) -> TcM ([Type], Maybe Type)
tcPartialContext TcTyMode
mode Maybe (LHsContext GhcRn)
hs_ctxt
; Type
ek <- TcM Type
newOpenTypeKind
; Type
tau <-
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
hs_tau Type
ek
; forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, TyVar)]
wcs, Maybe Type
wcx, [Type]
theta, Type
tau) }
; String -> SDoc -> TcM ()
traceTc String
"tcHsPartialSigType 2" forall doc. IsOutput doc => doc
empty
; HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs <- forall flag.
HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc)
scopedSortOuter HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs
; let outer_tv_bndrs :: [VarBndr TyVar Specificity]
outer_tv_bndrs = HsOuterTyVarBndrs Specificity GhcTc -> [VarBndr TyVar Specificity]
outerTyVarBndrs HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs
; String -> SDoc -> TcM ()
traceTc String
"tcHsPartialSigType 3" forall doc. IsOutput doc => doc
empty
; Type -> TcM ()
kindGeneralizeNone ([VarBndr TyVar Specificity] -> Type -> Type
mkInvisForAllTys [VarBndr TyVar Specificity]
outer_tv_bndrs forall a b. (a -> b) -> a -> b
$
HasDebugCallStack => [Type] -> Type -> Type
tcMkPhiTy [Type]
theta forall a b. (a -> b) -> a -> b
$
Type
tau)
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, TyVar) -> TcM ()
emitNamedTypeHole [(Name, TyVar)]
wcs
; ([(Name, VarBndr TyVar Specificity)]
tv_prs', [Type]
theta', Type
tau) <- Type -> TcM ([(Name, VarBndr TyVar Specificity)], [Type], Type)
tcInstTypeBndrs Type
tau
; let outer_bndr_names :: [Name]
outer_bndr_names :: HsQTvsRn
outer_bndr_names = forall flag. HsOuterTyVarBndrs flag GhcRn -> HsQTvsRn
hsOuterTyVarNames HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs
tv_prs :: [(Name,InvisTVBinder)]
tv_prs :: [(Name, VarBndr TyVar Specificity)]
tv_prs = HsQTvsRn
outer_bndr_names forall a b. [a] -> [b] -> [(a, b)]
`zip` [VarBndr TyVar Specificity]
outer_tv_bndrs
; [(Name, VarBndr TyVar Specificity)]
tv_prs <- forall (m :: * -> *) (f :: * -> *) b c a.
(Applicative m, Traversable f) =>
(b -> m c) -> f (a, b) -> m (f (a, c))
mapSndM forall spec. VarBndr TyVar spec -> TcM (VarBndr TyVar spec)
zonkInvisTVBinder ([(Name, VarBndr TyVar Specificity)]
tv_prs forall a. [a] -> [a] -> [a]
++ [(Name, VarBndr TyVar Specificity)]
tv_prs')
; [Type]
theta <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TcM Type
zonkTcType ([Type]
theta forall a. [a] -> [a] -> [a]
++ [Type]
theta')
; Type
tau <- Type -> TcM Type
zonkTcType Type
tau
; String -> SDoc -> TcM ()
traceTc String
"tcHsPartialSigType" (forall a. Outputable a => a -> SDoc
ppr [(Name, VarBndr TyVar Specificity)]
tv_prs)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, TyVar)]
wcs, Maybe Type
wcx, [(Name, VarBndr TyVar Specificity)]
tv_prs, [Type]
theta, Type
tau) }
tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM (TcThetaType, Maybe TcType)
tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM ([Type], Maybe Type)
tcPartialContext TcTyMode
_ Maybe (LHsContext GhcRn)
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return ([], forall a. Maybe a
Nothing)
tcPartialContext TcTyMode
mode (Just (L SrcSpanAnnC
_ [GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_theta))
| Just ([GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_theta1, GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ctxt_last) <- forall a. [a] -> Maybe ([a], a)
snocView [GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_theta
, L SrcSpanAnnA
wc_loc ty :: HsType GhcRn
ty@(HsWildCardTy XWildCardTy GhcRn
_) <- forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
ignoreParens GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ctxt_last
= do { Type
wc_tv_ty <- forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
wc_loc forall a b. (a -> b) -> a -> b
$
IsExtraConstraint -> TcTyMode -> HsType GhcRn -> Type -> TcM Type
tcAnonWildCardOcc IsExtraConstraint
YesExtraConstraint TcTyMode
mode HsType GhcRn
ty Type
constraintKind
; [Type]
theta <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcTyMode -> LHsType GhcRn -> TcM Type
tc_lhs_pred TcTyMode
mode) [GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_theta1
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
theta, forall a. a -> Maybe a
Just Type
wc_tv_ty) }
| Bool
otherwise
= do { [Type]
theta <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcTyMode -> LHsType GhcRn -> TcM Type
tc_lhs_pred TcTyMode
mode) [GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_theta
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
theta, forall a. Maybe a
Nothing) }
tcHsPatSigType :: UserTypeCtxt
-> HoleMode
-> HsPatSigType GhcRn
-> ContextKind
-> TcM ( [(Name, TcTyVar)]
, [(Name, TcTyVar)]
, TcType)
tcHsPatSigType :: UserTypeCtxt
-> HoleMode
-> HsPatSigType GhcRn
-> ContextKind
-> TcM ([(Name, TyVar)], [(Name, TyVar)], Type)
tcHsPatSigType UserTypeCtxt
ctxt HoleMode
hole_mode
(HsPS { hsps_ext :: forall pass. HsPatSigType pass -> XHsPS pass
hsps_ext = HsPSRn { hsps_nwcs :: HsPSRn -> HsQTvsRn
hsps_nwcs = HsQTvsRn
sig_wcs, hsps_imp_tvs :: HsPSRn -> HsQTvsRn
hsps_imp_tvs = HsQTvsRn
sig_ns }
, hsps_body :: forall pass. HsPatSigType pass -> LHsType pass
hsps_body = LHsType GhcRn
hs_ty })
ContextKind
ctxt_kind
= forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt LHsType GhcRn
hs_ty forall a b. (a -> b) -> a -> b
$
do { [(Name, TyVar)]
sig_tkv_prs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> IOEnv (Env TcGblEnv TcLclEnv) (Name, TyVar)
new_implicit_tv HsQTvsRn
sig_ns
; TcTyMode
mode <- TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode TypeOrKind
TypeLevel HoleMode
hole_mode
; ([(Name, TyVar)]
wcs, Type
sig_ty)
<- forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty forall a b. (a -> b) -> a -> b
$
forall a. String -> TcM a -> TcM a
solveEqualities String
"tcHsPatSigType" forall a b. (a -> b) -> a -> b
$
forall a. HsQTvsRn -> ([(Name, TyVar)] -> TcM a) -> TcM a
bindNamedWildCardBinders HsQTvsRn
sig_wcs forall a b. (a -> b) -> a -> b
$ \ [(Name, TyVar)]
wcs ->
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
sig_tkv_prs forall a b. (a -> b) -> a -> b
$
do { Type
ek <- ContextKind -> TcM Type
newExpectedKind ContextKind
ctxt_kind
; Type
sig_ty <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
hs_ty Type
ek
; forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, TyVar)]
wcs, Type
sig_ty) }
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, TyVar) -> TcM ()
emitNamedTypeHole [(Name, TyVar)]
wcs
; Type -> TcM ()
kindGeneralizeNone Type
sig_ty
; Type
sig_ty <- Type -> TcM Type
zonkTcType Type
sig_ty
; UserTypeCtxt -> Type -> TcM ()
checkValidType UserTypeCtxt
ctxt Type
sig_ty
; String -> SDoc -> TcM ()
traceTc String
"tcHsPatSigType" (forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
sig_tkv_prs)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, TyVar)]
wcs, [(Name, TyVar)]
sig_tkv_prs, Type
sig_ty) }
where
new_implicit_tv :: Name -> IOEnv (Env TcGblEnv TcLclEnv) (Name, TyVar)
new_implicit_tv Name
name
= do { Type
kind <- TcM Type
newMetaKindVar
; TyVar
tv <- case UserTypeCtxt
ctxt of
RuleSigCtxt FastString
rname Name
_ -> do
SkolemInfo
skol_info <- forall (m :: * -> *). MonadIO m => SkolemInfoAnon -> m SkolemInfo
mkSkolemInfo (FastString -> SkolemInfoAnon
RuleSkol FastString
rname)
SkolemInfo -> Name -> Type -> TcM TyVar
newSkolemTyVar SkolemInfo
skol_info Name
name Type
kind
UserTypeCtxt
_ -> Name -> Type -> TcM TyVar
newPatSigTyVar Name
name Type
kind
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name
name, TyVar
tv) }
unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)
unifyKinds :: [LHsType GhcRn] -> [(Type, Type)] -> TcM ([Type], Type)
unifyKinds [LHsType GhcRn]
rn_tys [(Type, Type)]
act_kinds
= do { Type
kind <- TcM Type
newMetaKindVar
; let check :: GenLocated SrcSpanAnnA (HsType GhcRn) -> (Type, Type) -> TcM Type
check GenLocated SrcSpanAnnA (HsType GhcRn)
rn_ty (Type
ty, Type
act_kind)
= HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcRn)
rn_ty) Type
ty Type
act_kind Type
kind
; [Type]
tys' <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM GenLocated SrcSpanAnnA (HsType GhcRn) -> (Type, Type) -> TcM Type
check [LHsType GhcRn]
rn_tys [(Type, Type)]
act_kinds
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
tys', Type
kind) }
tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
tcLHsKindSig :: UserTypeCtxt -> LHsType GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
ctxt LHsType GhcRn
hs_kind
= TcTyMode -> UserTypeCtxt -> LHsType GhcRn -> TcM Type
tc_lhs_kind_sig TcTyMode
kindLevelMode UserTypeCtxt
ctxt LHsType GhcRn
hs_kind
tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsType GhcRn -> TcM Type
tc_lhs_kind_sig TcTyMode
mode UserTypeCtxt
ctxt LHsType GhcRn
hs_kind
= do { Type
kind <- forall a. SDoc -> TcM a -> TcM a
addErrCtxt (forall doc. IsLine doc => String -> doc
text String
"In the kind" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr LHsType GhcRn
hs_kind)) forall a b. (a -> b) -> a -> b
$
forall a. String -> TcM a -> TcM a
solveEqualities String
"tcLHsKindSig" forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
hs_kind Type
liftedTypeKind
; String -> SDoc -> TcM ()
traceTc String
"tcLHsKindSig" (forall a. Outputable a => a -> SDoc
ppr LHsType GhcRn
hs_kind forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Outputable a => a -> SDoc
ppr Type
kind)
; Type -> TcM ()
kindGeneralizeNone Type
kind
; Type
kind <- Type -> TcM Type
zonkTcType Type
kind
; UserTypeCtxt -> Type -> TcM ()
checkValidType UserTypeCtxt
ctxt Type
kind
; String -> SDoc -> TcM ()
traceTc String
"tcLHsKindSig2" (forall a. Outputable a => a -> SDoc
ppr Type
kind)
; forall (m :: * -> *) a. Monad m => a -> m a
return Type
kind }
promotionErr :: Name -> PromotionErr -> TcM a
promotionErr :: forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name PromotionErr
err
= forall a. TcRnMessage -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$ Name -> PromotionErr -> TcRnMessage
TcRnUnpromotableThing Name
name PromotionErr
err
funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc
funAppCtxt :: forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Arity -> SDoc
funAppCtxt fun
fun arg
arg Arity
arg_no
= SDoc -> Arity -> SDoc -> SDoc
hang (forall doc. IsLine doc => [doc] -> doc
hsep [ forall doc. IsLine doc => String -> doc
text String
"In the", Arity -> SDoc
speakNth Arity
arg_no, forall doc. IsLine doc => String -> doc
text String
"argument of",
SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr fun
fun) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
", namely"])
Arity
2 (SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr arg
arg))
addTyConFlavCtxt :: Name -> TyConFlavour -> TcM a -> TcM a
addTyConFlavCtxt :: forall a. Name -> TyConFlavour -> TcM a -> TcM a
addTyConFlavCtxt Name
name TyConFlavour
flav
= forall a. SDoc -> TcM a -> TcM a
addErrCtxt forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => [doc] -> doc
hsep [ forall doc. IsLine doc => String -> doc
text String
"In the", forall a. Outputable a => a -> SDoc
ppr TyConFlavour
flav
, forall doc. IsLine doc => String -> doc
text String
"declaration for", SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name) ]