{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# 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, bindOuterFamEqnTKBndrs_Q_Tv,
tcOuterTKBndrs, scopedSortOuter,
bindOuterSigTKBndrs_Tv,
tcExplicitTKBndrs,
bindNamedWildCardBinders,
bindTyClTyVars, tcFamTyPats,
etaExpandAlgTyCon, tcbVisibilities,
zonkAndScopedSort,
InitialKindStrategy(..),
SAKS_or_CUSK(..),
ContextKind(..),
kcDeclHeader,
tcHsLiftedType, tcHsOpenType,
tcHsLiftedTypeNC, tcHsOpenTypeNC,
tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated,
tcCheckLHsType,
tcHsContext, tcLHsPredType,
kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone,
tcLHsKindSig, checkDataKindSig, DataSort(..),
checkClassKindSig,
tcMult,
tcHsPatSigType,
HoleMode(..),
funAppCtxt, addTyConFlavCtxt
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Hs
import GHC.Rename.Utils
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Origin
import GHC.Core.Predicate
import GHC.Tc.Types.Constraint
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcMType
import GHC.Tc.Validity
import GHC.Tc.Utils.Unify
import GHC.IfaceToCore
import GHC.Tc.Solver
import GHC.Tc.Utils.Zonk
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN,
tcInstInvisibleTyBinder )
import GHC.Core.Type
import GHC.Builtin.Types.Prim
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.Types.Unique.Set
import GHC.Utils.Misc
import GHC.Types.Unique.Supply
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Builtin.Names hiding ( wildCardName )
import GHC.Driver.Session
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.Maybe
import GHC.Data.Bag( unitBag )
import Data.List ( find )
import Control.Monad
funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt
funsSigCtxt :: [GenLocated SrcSpanAnnN Name] -> UserTypeCtxt
funsSigCtxt (L SrcSpanAnnN
_ Name
name1 : [GenLocated SrcSpanAnnN Name]
_) = Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
name1 Bool
False
funsSigCtxt [] = String -> UserTypeCtxt
forall a. String -> a
panic String
"funSigCtxt"
addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt :: forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt LocatedA hs_ty
hs_ty TcM a
thing_inside
= SrcSpan -> TcM a -> TcM a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (LocatedA hs_ty -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LocatedA hs_ty
hs_ty) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (UserTypeCtxt -> LocatedA hs_ty -> SDoc
forall hs_ty.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> SDoc
pprSigCtxt UserTypeCtxt
ctxt LocatedA hs_ty
hs_ty) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc
pprSigCtxt :: forall hs_ty.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> SDoc
pprSigCtxt UserTypeCtxt
ctxt LocatedA hs_ty
hs_ty
| Just Name
n <- UserTypeCtxt -> Maybe Name
isSigMaybe UserTypeCtxt
ctxt
= SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"In the type signature:")
Arity
2 (Name -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Name
n SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> LocatedA hs_ty -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedA hs_ty
hs_ty)
| Bool
otherwise
= SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"In" SDoc -> SDoc -> SDoc
<+> UserTypeCtxt -> SDoc
pprUserTypeCtxt UserTypeCtxt
ctxt SDoc -> SDoc -> SDoc
<> SDoc
colon)
Arity
2 (LocatedA hs_ty -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedA hs_ty
hs_ty)
tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
tcHsSigWcType UserTypeCtxt
ctxt LHsSigWcType GhcRn
sig_ty = UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType UserTypeCtxt
ctxt (LHsSigWcType GhcRn -> LHsSigType GhcRn
forall pass. LHsSigWcType pass -> LHsSigType pass
dropWildCards LHsSigWcType GhcRn
sig_ty)
kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM ()
kcClassSigType :: [GenLocated SrcSpanAnnN Name] -> LHsSigType GhcRn -> TcM ()
kcClassSigType [GenLocated SrcSpanAnnN Name]
names
sig_ty :: LHsSigType GhcRn
sig_ty@(L SrcSpanAnnA
_ (HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcRn
hs_ty }))
= UserTypeCtxt
-> GenLocated SrcSpanAnnA (HsSigType GhcRn) -> TcM () -> TcM ()
forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt ([GenLocated SrcSpanAnnN Name] -> UserTypeCtxt
funsSigCtxt [GenLocated SrcSpanAnnN Name]
names) GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType GhcRn
sig_ty (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
do { (HsOuterTyVarBndrs Specificity GhcTc, Type)
_ <- HsOuterSigTyVarBndrs GhcRn
-> TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
forall a.
HsOuterSigTyVarBndrs GhcRn
-> TcM a -> TcM (HsOuterTyVarBndrs Specificity GhcTc, a)
bindOuterSigTKBndrs_Tv HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs (TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type))
-> TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
liftedTypeKind
; () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type
tcClassSigType :: [GenLocated SrcSpanAnnN Name] -> LHsSigType GhcRn -> TcM Type
tcClassSigType [GenLocated SrcSpanAnnN Name]
names LHsSigType GhcRn
sig_ty
= UserTypeCtxt
-> GenLocated SrcSpanAnnA (HsSigType GhcRn) -> TcM Type -> TcM Type
forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
sig_ctxt GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType GhcRn
sig_ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
do { (Implication
implic, Type
ty) <- SkolemInfo
-> LHsSigType GhcRn -> ContextKind -> TcM (Implication, Type)
tc_lhs_sig_type SkolemInfo
skol_info LHsSigType GhcRn
sig_ty (Type -> ContextKind
TheKind Type
liftedTypeKind)
; Implication -> TcM ()
emitImplication Implication
implic
; Type -> TcM Type
forall (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 :: SkolemInfo
skol_info = UserTypeCtxt -> SkolemInfo
SigTypeSkol UserTypeCtxt
sig_ctxt
tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType UserTypeCtxt
ctxt LHsSigType GhcRn
sig_ty
= UserTypeCtxt
-> GenLocated SrcSpanAnnA (HsSigType GhcRn) -> TcM Type -> TcM Type
forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType GhcRn
sig_ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcM ()
traceTc String
"tcHsSigType {" (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType GhcRn
sig_ty)
; (Implication
implic, Type
ty) <- SkolemInfo
-> LHsSigType GhcRn -> ContextKind -> TcM (Implication, Type)
tc_lhs_sig_type SkolemInfo
skol_info LHsSigType GhcRn
sig_ty (UserTypeCtxt -> ContextKind
expectedKindInCtxt UserTypeCtxt
ctxt)
; String -> SDoc -> TcM ()
traceTc String
"tcHsSigType 2" (Implication -> SDoc
forall a. Outputable a => a -> SDoc
ppr Implication
implic)
; WantedConstraints -> TcM ()
simplifyAndEmitFlatConstraints (Bag Implication -> WantedConstraints
mkImplicWC (Implication -> Bag Implication
forall a. a -> Bag a
unitBag Implication
implic))
; Type
ty <- Type -> TcM Type
zonkTcType Type
ty
; UserTypeCtxt -> Type -> TcM ()
checkValidType UserTypeCtxt
ctxt Type
ty
; String -> SDoc -> TcM ()
traceTc String
"end tcHsSigType }" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
; Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty }
where
skol_info :: SkolemInfo
skol_info = UserTypeCtxt -> SkolemInfo
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 (L SrcSpanAnnA
loc (HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs
, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcRn
hs_ty })) ContextKind
ctxt_kind
= SrcSpanAnnA -> TcM (Implication, Type) -> TcM (Implication, Type)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (Implication, Type) -> TcM (Implication, Type))
-> TcM (Implication, Type) -> TcM (Implication, Type)
forall a b. (a -> b) -> a -> b
$
do { (TcLevel
tc_lvl, WantedConstraints
wanted, (HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs, Type
ty))
<- String
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
-> TcM
(TcLevel, WantedConstraints,
(HsOuterTyVarBndrs Specificity GhcTc, Type))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tc_lhs_sig_type" (TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
-> TcM
(TcLevel, WantedConstraints,
(HsOuterTyVarBndrs Specificity GhcTc, Type)))
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
-> TcM
(TcLevel, WantedConstraints,
(HsOuterTyVarBndrs Specificity GhcTc, Type))
forall a b. (a -> b) -> a -> b
$
SkolemInfo
-> HsOuterSigTyVarBndrs GhcRn
-> TcM Type
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrs SkolemInfo
skol_info HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs (TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type))
-> TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
do { Type
kind <- ContextKind -> TcM Type
newExpectedKind ContextKind
ctxt_kind
; LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
kind }
; String -> SDoc -> TcM ()
traceTc String
"tc_lhs_sig_type" (HsOuterSigTyVarBndrs GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs SDoc -> SDoc -> SDoc
$$ HsOuterTyVarBndrs Specificity GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs)
; ([InvisTVBinder]
outer_tv_bndrs :: [InvisTVBinder]) <- HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder]
scopedSortOuter HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs
; let ty1 :: Type
ty1 = [InvisTVBinder] -> Type -> Type
mkInvisForAllTys [InvisTVBinder]
outer_tv_bndrs Type
ty
; [TyVar]
kvs <- WantedConstraints -> Type -> TcM [TyVar]
kindGeneralizeSome WantedConstraints
wanted Type
ty1
; Implication
implic <- SkolemInfo
-> [TyVar] -> TcLevel -> WantedConstraints -> TcM Implication
buildTvImplication SkolemInfo
skol_info [TyVar]
kvs TcLevel
tc_lvl WantedConstraints
wanted
; (Implication, Type) -> TcM (Implication, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Implication
implic, [TyVar] -> Type -> Type
mkInfForAllTys [TyVar]
kvs Type
ty1) }
tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)
tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Type)
tcStandaloneKindSig (L SrcSpanAnnA
_ (StandaloneKindSig XStandaloneKindSig GhcRn
_ (L SrcSpanAnnN
_ Name
name) LHsSigType GhcRn
ksig))
= UserTypeCtxt
-> GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> TcM (Name, Type)
-> TcM (Name, Type)
forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType GhcRn
ksig (TcM (Name, Type) -> TcM (Name, Type))
-> TcM (Name, Type) -> TcM (Name, Type)
forall a b. (a -> b) -> a -> b
$
do { Type
kind <- TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tc_top_lhs_type TypeOrKind
KindLevel UserTypeCtxt
ctxt LHsSigType GhcRn
ksig
; UserTypeCtxt -> Type -> TcM ()
checkValidType UserTypeCtxt
ctxt Type
kind
; (Name, Type) -> TcM (Name, Type)
forall (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
= TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tc_top_lhs_type TypeOrKind
TypeLevel UserTypeCtxt
ctxt LHsSigType GhcRn
lsig_ty
tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tc_top_lhs_type TypeOrKind
tyki UserTypeCtxt
ctxt (L SrcSpanAnnA
loc sig_ty :: HsSigType GhcRn
sig_ty@(HsSig { sig_bndrs :: forall pass. HsSigType pass -> HsOuterSigTyVarBndrs pass
sig_bndrs = HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs
, sig_body :: forall pass. HsSigType pass -> LHsType pass
sig_body = LHsType GhcRn
body }))
= SrcSpanAnnA -> TcM Type -> TcM Type
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcM ()
traceTc String
"tc_top_lhs_type {" (HsSigType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsSigType GhcRn
sig_ty)
; (TcLevel
tclvl, WantedConstraints
wanted, (HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs, Type
ty))
<- String
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
-> TcM
(TcLevel, WantedConstraints,
(HsOuterTyVarBndrs Specificity GhcTc, Type))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"tc_top_lhs_type" (TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
-> TcM
(TcLevel, WantedConstraints,
(HsOuterTyVarBndrs Specificity GhcTc, Type)))
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
-> TcM
(TcLevel, WantedConstraints,
(HsOuterTyVarBndrs Specificity GhcTc, Type))
forall a b. (a -> b) -> a -> b
$
SkolemInfo
-> HsOuterSigTyVarBndrs GhcRn
-> TcM Type
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrs SkolemInfo
skol_info HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs (TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type))
-> TcM Type -> TcM (HsOuterTyVarBndrs Specificity GhcTc, Type)
forall a b. (a -> b) -> a -> b
$
do { Type
kind <- ContextKind -> TcM Type
newExpectedKind (UserTypeCtxt -> ContextKind
expectedKindInCtxt UserTypeCtxt
ctxt)
; TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type (TypeOrKind -> TcTyMode
mkMode TypeOrKind
tyki) LHsType GhcRn
body Type
kind }
; [InvisTVBinder]
outer_tv_bndrs <- HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder]
scopedSortOuter HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs
; let ty1 :: Type
ty1 = [InvisTVBinder] -> Type -> Type
mkInvisForAllTys [InvisTVBinder]
outer_tv_bndrs Type
ty
; [TyVar]
kvs <- Type -> TcM [TyVar]
kindGeneralizeAll Type
ty1
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcM ()
reportUnsolvedEqualities SkolemInfo
skol_info [TyVar]
kvs TcLevel
tclvl WantedConstraints
wanted
; ZonkEnv
ze <- ZonkFlexi -> TcM ZonkEnv
mkEmptyZonkEnv ZonkFlexi
NoFlexi
; Type
final_ty <- ZonkEnv -> Type -> TcM Type
zonkTcTypeToTypeX ZonkEnv
ze ([TyVar] -> Type -> Type
mkInfForAllTys [TyVar]
kvs Type
ty1)
; String -> SDoc -> TcM ()
traceTc String
"tc_top_lhs_type }" ([SDoc] -> SDoc
vcat [HsSigType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsSigType GhcRn
sig_ty, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
final_ty])
; Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
final_ty }
where
skol_info :: SkolemInfo
skol_info = UserTypeCtxt -> SkolemInfo
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 <- TcM Type -> TcM Type
forall r. TcM r -> TcM r
checkNoErrs (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
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
Type -> Type
tcTypeKind Type
pred)
; case Type -> Maybe (Class, [Type])
getClassPredTys_maybe Type
pred of
Just (Class
cls, [Type]
tys) -> ([TyVar], Class, [Type], [Type])
-> TcM ([TyVar], Class, [Type], [Type])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
tvs, Class
cls, [Type]
tys, (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
kind_args)
Maybe (Class, [Type])
Nothing -> SDoc -> TcM ([TyVar], Class, [Type], [Type])
forall a. SDoc -> TcM a
failWithTc (String -> SDoc
text String
"Illegal deriving item" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType GhcRn
hs_ty)) }
tcDerivStrategy ::
Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
tcDerivStrategy :: Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
tcDerivStrategy Maybe (LDerivStrategy GhcRn)
mb_lds
= case Maybe (LDerivStrategy GhcRn)
mb_lds of
Maybe (LDerivStrategy GhcRn)
Nothing -> Maybe (GenLocated SrcSpan (DerivStrategy GhcTc))
-> TcM (Maybe (GenLocated SrcSpan (DerivStrategy GhcTc)), [TyVar])
forall ds. ds -> TcM (ds, [TyVar])
boring_case Maybe (GenLocated SrcSpan (DerivStrategy GhcTc))
forall a. Maybe a
Nothing
Just (L SrcSpan
loc DerivStrategy GhcRn
ds) ->
SrcSpan
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar]))
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
forall a b. (a -> b) -> a -> b
$ do
(DerivStrategy GhcTc
ds', [TyVar]
tvs) <- DerivStrategy GhcRn -> TcM (DerivStrategy GhcTc, [TyVar])
tc_deriv_strategy DerivStrategy GhcRn
ds
(Maybe (GenLocated SrcSpan (DerivStrategy GhcTc)), [TyVar])
-> TcM (Maybe (GenLocated SrcSpan (DerivStrategy GhcTc)), [TyVar])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpan (DerivStrategy GhcTc)
-> Maybe (GenLocated SrcSpan (DerivStrategy GhcTc))
forall a. a -> Maybe a
Just (SrcSpan
-> DerivStrategy GhcTc -> GenLocated SrcSpan (DerivStrategy GhcTc)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc DerivStrategy GhcTc
ds'), [TyVar]
tvs)
where
tc_deriv_strategy :: DerivStrategy GhcRn
-> TcM (DerivStrategy GhcTc, [TyVar])
tc_deriv_strategy :: DerivStrategy GhcRn -> TcM (DerivStrategy GhcTc, [TyVar])
tc_deriv_strategy (StockStrategy XStockStrategy GhcRn
_)
= DerivStrategy GhcTc -> TcM (DerivStrategy GhcTc, [TyVar])
forall ds. ds -> TcM (ds, [TyVar])
boring_case (XStockStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XStockStrategy pass -> DerivStrategy pass
StockStrategy NoExtField
XStockStrategy GhcTc
noExtField)
tc_deriv_strategy (AnyclassStrategy XAnyClassStrategy GhcRn
_)
= DerivStrategy GhcTc -> TcM (DerivStrategy GhcTc, [TyVar])
forall ds. ds -> TcM (ds, [TyVar])
boring_case (XAnyClassStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XAnyClassStrategy pass -> DerivStrategy pass
AnyclassStrategy NoExtField
XAnyClassStrategy GhcTc
noExtField)
tc_deriv_strategy (NewtypeStrategy XNewtypeStrategy GhcRn
_)
= DerivStrategy GhcTc -> TcM (DerivStrategy GhcTc, [TyVar])
forall ds. ds -> TcM (ds, [TyVar])
boring_case (XNewtypeStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XNewtypeStrategy pass -> DerivStrategy pass
NewtypeStrategy NoExtField
XNewtypeStrategy GhcTc
noExtField)
tc_deriv_strategy (ViaStrategy XViaStrategy GhcRn
ty) = do
Type
ty' <- TcM Type -> TcM Type
forall r. TcM r -> TcM r
checkNoErrs (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$ UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcTopLHsType UserTypeCtxt
DerivClauseCtxt LHsSigType GhcRn
XViaStrategy GhcRn
ty
let ([TyVar]
via_tvs, Type
via_pred) = Type -> ([TyVar], Type)
splitForAllTyCoVars Type
ty'
(DerivStrategy GhcTc, [TyVar])
-> TcM (DerivStrategy GhcTc, [TyVar])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (XViaStrategy GhcTc -> DerivStrategy GhcTc
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy Type
XViaStrategy GhcTc
via_pred, [TyVar]
via_tvs)
boring_case :: ds -> TcM (ds, [TyVar])
boring_case :: forall ds. ds -> TcM (ds, [TyVar])
boring_case ds
ds = (ds, [TyVar]) -> IOEnv (Env TcGblEnv TcLclEnv) (ds, [TyVar])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ds
ds, [])
tcHsClsInstType :: UserTypeCtxt
-> LHsSigType GhcRn
-> TcM Type
tcHsClsInstType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsClsInstType UserTypeCtxt
user_ctxt LHsSigType GhcRn
hs_inst_ty
= SrcSpan -> TcM Type -> TcM Type
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType GhcRn
hs_inst_ty) (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
do {
Type
inst_ty <- TcM Type -> TcM Type
forall r. TcM r -> TcM r
checkNoErrs (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcTopLHsType UserTypeCtxt
user_ctxt LHsSigType GhcRn
hs_inst_ty
; UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM ()
checkValidInstance UserTypeCtxt
user_ctxt LHsSigType GhcRn
hs_inst_ty Type
inst_ty
; Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
inst_ty }
tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type
tcHsTypeApp :: LHsWcType GhcRn -> Type -> TcM Type
tcHsTypeApp LHsWcType GhcRn
wc_ty Type
kind
| HsWC { hswc_ext :: forall pass thing. HsWildCardBndrs pass thing -> XHsWC pass thing
hswc_ext = XHsWC GhcRn (LHsType GhcRn)
sig_wcs, hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = LHsType GhcRn
hs_ty } <- LHsWcType GhcRn
wc_ty
= do { TcTyMode
mode <- TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode TypeOrKind
TypeLevel HoleMode
HM_VTA
; Type
ty <- LHsType GhcRn -> TcM Type -> TcM Type
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
String -> TcM Type -> TcM Type
forall a. String -> TcM a -> TcM a
solveEqualities String
"tcHsTypeApp" (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
HsQTvsRn -> ([(Name, TyVar)] -> TcM Type) -> TcM Type
forall a. HsQTvsRn -> ([(Name, TyVar)] -> TcM a) -> TcM a
bindNamedWildCardBinders HsQTvsRn
XHsWC GhcRn (LHsType GhcRn)
sig_wcs (([(Name, TyVar)] -> TcM Type) -> TcM Type)
-> ([(Name, TyVar)] -> TcM Type) -> TcM Type
forall a b. (a -> b) -> a -> b
$ \ [(Name, TyVar)]
_ ->
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
hs_ty Type
kind
; Type -> TcM ()
kindGeneralizeNone Type
ty
; Type
ty <- Type -> TcM Type
zonkTcType Type
ty
; UserTypeCtxt -> Type -> TcM ()
checkValidType UserTypeCtxt
TypeAppCtxt Type
ty
; Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty }
tcFamTyPats :: TyCon
-> HsTyPats GhcRn
-> TcM (TcType, TcKind)
tcFamTyPats :: TyCon -> HsTyPats GhcRn -> TcM (Type, Type)
tcFamTyPats TyCon
fam_tc HsTyPats GhcRn
hs_pats
= do { String -> SDoc -> TcM ()
traceTc String
"tcFamTyPats {" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc, String -> SDoc
text String
"arity:" SDoc -> SDoc -> SDoc
<+> Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
fam_arity ]
; TcTyMode
mode <- TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode TypeOrKind
TypeLevel HoleMode
HM_FamPat
; let fun_ty :: Type
fun_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc []
; (Type
fam_app, Type
res_kind) <- TcTyMode
-> LHsType GhcRn -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
tcInferTyApps TcTyMode
mode GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
lhs_fun Type
fun_ty HsTyPats GhcRn
hs_pats
; Type
res_kind <- Type -> TcM Type
zonkTcType Type
res_kind
; String -> SDoc -> TcM ()
traceTc String
"End tcFamTyPats }" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
fam_tc, String -> SDoc
text String
"res_kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
res_kind ]
; (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
fam_app, Type
res_kind) }
where
fam_name :: Name
fam_name = TyCon -> Name
tyConName TyCon
fam_tc
fam_arity :: Arity
fam_arity = TyCon -> Arity
tyConArity TyCon
fam_tc
lhs_fun :: GenLocated SrcSpanAnnA (HsType GhcRn)
lhs_fun = HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a an. a -> LocatedAn an a
noLocA (XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcRn
forall a. EpAnn a
noAnn PromotionFlag
NotPromoted (Name -> GenLocated SrcSpanAnnN Name
forall a an. a -> LocatedAn an a
noLocA Name
fam_name))
tcHsOpenType, tcHsLiftedType,
tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType
tcHsOpenType :: LHsType GhcRn -> TcM Type
tcHsOpenType LHsType GhcRn
hs_ty = LHsType GhcRn -> TcM Type -> TcM Type
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> TcM Type
tcHsOpenTypeNC LHsType GhcRn
hs_ty
tcHsLiftedType :: LHsType GhcRn -> TcM Type
tcHsLiftedType LHsType GhcRn
hs_ty = LHsType GhcRn -> TcM Type -> TcM Type
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> TcM Type
tcHsLiftedTypeNC LHsType GhcRn
hs_ty
tcHsOpenTypeNC :: LHsType GhcRn -> TcM Type
tcHsOpenTypeNC LHsType GhcRn
hs_ty = do { Type
ek <- TcM Type
newOpenTypeKind; LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
ek }
tcHsLiftedTypeNC :: LHsType GhcRn -> TcM Type
tcHsLiftedTypeNC LHsType GhcRn
hs_ty = LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
liftedTypeKind
tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType
tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM Type
tcCheckLHsType LHsType GhcRn
hs_ty ContextKind
exp_kind
= LHsType GhcRn -> TcM Type -> TcM Type
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
do { Type
ek <- ContextKind -> TcM Type
newExpectedKind ContextKind
exp_kind
; LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
ek }
tcInferLHsType :: LHsType GhcRn -> TcM TcType
tcInferLHsType :: LHsType GhcRn -> TcM Type
tcInferLHsType LHsType GhcRn
hs_ty
= do { (Type
ty,Type
_kind) <- LHsType GhcRn -> TcM (Type, Type)
tcInferLHsTypeKind LHsType GhcRn
hs_ty
; Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty }
tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind)
tcInferLHsTypeKind :: LHsType GhcRn -> TcM (Type, Type)
tcInferLHsTypeKind lhs_ty :: LHsType GhcRn
lhs_ty@(L SrcSpanAnnA
loc HsType GhcRn
hs_ty)
= LHsType GhcRn -> TcM (Type, Type) -> TcM (Type, Type)
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
lhs_ty (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
SrcSpanAnnA -> TcM (Type, Type) -> TcM (Type, Type)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
do { (Type
res_ty, Type
res_kind) <- TcTyMode -> HsType GhcRn -> TcM (Type, Type)
tc_infer_hs_type TcTyMode
typeLevelMode HsType GhcRn
hs_ty
; Type -> Type -> TcM (Type, Type)
tcInstInvisibleTyBinders Type
res_ty Type
res_kind }
tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)
tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (Type, Type)
tcInferLHsTypeUnsaturated LHsType GhcRn
hs_ty
= LHsType GhcRn -> TcM (Type, Type) -> TcM (Type, Type)
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
do { TcTyMode
mode <- TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode TypeOrKind
TypeLevel HoleMode
HM_Sig
; case HsType GhcRn -> Maybe (LHsType GhcRn, HsTyPats GhcRn)
splitHsAppTys (GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcRn)
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 = HoleInfo
forall a. Maybe a
Nothing }
typeLevelMode, kindLevelMode :: TcTyMode
kindLevelMode :: TcTyMode
kindLevelMode = TypeOrKind -> TcTyMode
mkMode TypeOrKind
KindLevel
typeLevelMode :: TcTyMode
typeLevelMode = TypeOrKind -> TcTyMode
mkMode TypeOrKind
TypeLevel
mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode TypeOrKind
tyki HoleMode
hm
= do { TcLevel
lvl <- TcM TcLevel
getTcLevel
; TcTyMode -> TcM TcTyMode
forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyMode { mode_tyki :: TypeOrKind
mode_tyki = TypeOrKind
tyki
, mode_holes :: HoleInfo
mode_holes = (TcLevel, HoleMode) -> HoleInfo
forall a. a -> Maybe a
Just (TcLevel
lvl,HoleMode
hm) }) }
instance Outputable HoleMode where
ppr :: HoleMode -> SDoc
ppr HoleMode
HM_Sig = String -> SDoc
text String
"HM_Sig"
ppr HoleMode
HM_FamPat = String -> SDoc
text String
"HM_FamPat"
ppr HoleMode
HM_VTA = String -> SDoc
text String
"HM_VTA"
ppr HoleMode
HM_TyAppPat = String -> SDoc
text String
"HM_TyAppPat"
instance Outputable TcTyMode where
ppr :: TcTyMode -> SDoc
ppr (TcTyMode { mode_tyki :: TcTyMode -> TypeOrKind
mode_tyki = TypeOrKind
tyki, mode_holes :: TcTyMode -> HoleInfo
mode_holes = HoleInfo
hm })
= String -> SDoc
text String
"TcTyMode" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
sep [ TypeOrKind -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeOrKind
tyki SDoc -> SDoc -> SDoc
<> SDoc
comma
, HoleInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr HoleInfo
hm ])
tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)
tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode (L SrcSpanAnnA
span HsType GhcRn
ty)
= SrcSpanAnnA -> TcM (Type, Type) -> TcM (Type, Type)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
span (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
TcTyMode -> HsType GhcRn -> TcM (Type, Type)
tc_infer_hs_type TcTyMode
mode HsType GhcRn
ty
tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
tc_infer_hs_type_ek :: 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
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
hs_ty Type
ty Type
k Type
ek }
tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)
tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (Type, Type)
tc_infer_hs_type TcTyMode
mode (HsParTy XParTy GhcRn
_ LHsType GhcRn
t)
= TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode LHsType GhcRn
t
tc_infer_hs_type TcTyMode
mode HsType GhcRn
ty
| Just (LHsType GhcRn
hs_fun_ty, HsTyPats GhcRn
hs_args) <- HsType GhcRn -> Maybe (LHsType GhcRn, HsTyPats GhcRn)
splitHsAppTys HsType GhcRn
ty
= do { (Type
fun_ty, Type
_ki) <- TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tcInferTyAppHead TcTyMode
mode LHsType GhcRn
hs_fun_ty
; TcTyMode
-> LHsType GhcRn -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
tcInferTyApps TcTyMode
mode LHsType GhcRn
hs_fun_ty Type
fun_ty HsTyPats GhcRn
hs_args }
tc_infer_hs_type TcTyMode
mode (HsKindSig XKindSig GhcRn
_ LHsType GhcRn
ty LHsType GhcRn
sig)
= do { let mode' :: TcTyMode
mode' = TcTyMode
mode { mode_tyki :: TypeOrKind
mode_tyki = TypeOrKind
KindLevel }
; Type
sig' <- TcTyMode -> UserTypeCtxt -> LHsType GhcRn -> TcM Type
tc_lhs_kind_sig TcTyMode
mode' UserTypeCtxt
KindSigCtxt LHsType GhcRn
sig
; String -> SDoc -> TcM ()
traceTc String
"tc_infer_hs_type:sig" (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
ty SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
sig')
; Type
ty' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty Type
sig'
; (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty', Type
sig') }
tc_infer_hs_type TcTyMode
mode (HsSpliceTy XSpliceTy GhcRn
_ (HsSpliced XSpliced GhcRn
_ ThModFinalizers
_ (HsSplicedTy HsType GhcRn
ty)))
= TcTyMode -> HsType GhcRn -> TcM (Type, Type)
tc_infer_hs_type TcTyMode
mode HsType GhcRn
ty
tc_infer_hs_type TcTyMode
mode (HsDocTy XDocTy GhcRn
_ LHsType GhcRn
ty LHsDocString
_) = TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode LHsType GhcRn
ty
tc_infer_hs_type TcTyMode
_ (XHsType XXType GhcRn
ty)
= do TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
let subst_prs :: [(Unique, TcTyVar)]
subst_prs :: [(Unique, TyVar)]
subst_prs = [ (Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique Name
nm, TyVar
tv)
| ATyVar Name
nm TyVar
tv <- NameEnv TcTyThing -> [TcTyThing]
forall a. NameEnv a -> [a]
nameEnvElts (TcLclEnv -> NameEnv TcTyThing
tcl_env TcLclEnv
env) ]
subst :: TCvSubst
subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst
(VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [TyVar] -> VarSet
mkVarSet ([TyVar] -> VarSet) -> [TyVar] -> VarSet
forall a b. (a -> b) -> a -> b
$ ((Unique, TyVar) -> TyVar) -> [(Unique, TyVar)] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map (Unique, TyVar) -> TyVar
forall a b. (a, b) -> b
snd [(Unique, TyVar)]
subst_prs)
([(Unique, Type)] -> TvSubstEnv
forall elt key. [(Unique, elt)] -> UniqFM key elt
listToUFM_Directly ([(Unique, Type)] -> TvSubstEnv) -> [(Unique, Type)] -> TvSubstEnv
forall a b. (a -> b) -> a -> b
$ ((Unique, TyVar) -> (Unique, Type))
-> [(Unique, TyVar)] -> [(Unique, Type)]
forall a b. (a -> b) -> [a] -> [b]
map ((TyVar -> Type) -> (Unique, TyVar) -> (Unique, Type)
forall a b c. (a -> b) -> (c, a) -> (c, b)
liftSnd TyVar -> Type
mkTyVarTy) [(Unique, TyVar)]
subst_prs)
ty' :: Type
ty' = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
XXType GhcRn
ty
(Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty', HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty')
tc_infer_hs_type TcTyMode
_ (HsExplicitListTy XExplicitListTy GhcRn
_ PromotionFlag
_ [LHsType GhcRn]
tys)
| [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsType GhcRn)]
[LHsType GhcRn]
tys
= (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Type
mkTyConTy TyCon
promotedNilDataCon,
[TyVar] -> Type -> Type
mkSpecForAllTys [TyVar
alphaTyVar] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
mkListTy Type
alphaTy)
tc_infer_hs_type TcTyMode
mode HsType GhcRn
other_ty
= do { Type
kv <- TcM Type
newMetaKindVar
; Type
ty' <- TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_hs_type TcTyMode
mode HsType GhcRn
other_ty Type
kv
; (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty', Type
kv) }
tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType
tcLHsType :: LHsType GhcRn -> Type -> TcM Type
tcLHsType LHsType GhcRn
hs_ty Type
exp_kind
= TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
typeLevelMode LHsType GhcRn
hs_ty Type
exp_kind
tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType
tc_lhs_type :: TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode (L SrcSpanAnnA
span HsType GhcRn
ty) Type
exp_kind
= SrcSpanAnnA -> TcM Type -> TcM Type
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
span (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_hs_type TcTyMode
mode HsType GhcRn
ty Type
exp_kind
tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
tc_hs_type :: TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_hs_type TcTyMode
mode (HsParTy XParTy GhcRn
_ LHsType GhcRn
ty) Type
exp_kind = TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty Type
exp_kind
tc_hs_type TcTyMode
mode (HsDocTy XDocTy GhcRn
_ LHsType GhcRn
ty LHsDocString
_) Type
exp_kind = TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty Type
exp_kind
tc_hs_type TcTyMode
_ ty :: HsType GhcRn
ty@(HsBangTy XBangTy GhcRn
_ HsSrcBang
bang LHsType GhcRn
_) Type
_
= do { let bangError :: String -> TcM Type
bangError String
err = SDoc -> TcM Type
forall a. SDoc -> TcM a
failWith (SDoc -> TcM Type) -> SDoc -> TcM Type
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Unexpected" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
err SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"annotation:" SDoc -> SDoc -> SDoc
<+> HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
ty SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
err SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"annotation cannot appear nested inside a type"
; case HsSrcBang
bang of
HsSrcBang SourceText
_ SrcUnpackedness
SrcUnpack SrcStrictness
_ -> String -> TcM Type
bangError String
"UNPACK"
HsSrcBang SourceText
_ SrcUnpackedness
SrcNoUnpack SrcStrictness
_ -> String -> TcM Type
bangError String
"NOUNPACK"
HsSrcBang SourceText
_ SrcUnpackedness
NoSrcUnpack SrcStrictness
SrcLazy -> String -> TcM Type
bangError String
"laziness"
HsSrcBang SourceText
_ SrcUnpackedness
_ SrcStrictness
_ -> String -> TcM Type
bangError String
"strictness" }
tc_hs_type TcTyMode
_ ty :: HsType GhcRn
ty@(HsRecTy {}) Type
_
= SDoc -> TcM Type
forall a. SDoc -> TcM a
failWithTc (String -> SDoc
text String
"Record syntax is illegal here:" SDoc -> SDoc -> SDoc
<+> HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
ty)
tc_hs_type TcTyMode
mode (HsSpliceTy XSpliceTy GhcRn
_ (HsSpliced XSpliced GhcRn
_ ThModFinalizers
mod_finalizers (HsSplicedTy HsType GhcRn
ty)))
Type
exp_kind
= do ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_hs_type TcTyMode
mode HsType GhcRn
ty Type
exp_kind
tc_hs_type TcTyMode
_ ty :: HsType GhcRn
ty@(HsSpliceTy {}) Type
_exp_kind
= SDoc -> TcM Type
forall a. SDoc -> TcM a
failWithTc (String -> SDoc
text String
"Unexpected type splice:" SDoc -> SDoc -> SDoc
<+> HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
ty)
tc_hs_type TcTyMode
mode (HsFunTy XFunTy GhcRn
_ HsArrow GhcRn
mult LHsType GhcRn
ty1 LHsType GhcRn
ty2) Type
exp_kind
= TcTyMode
-> HsArrow GhcRn
-> LHsType GhcRn
-> LHsType GhcRn
-> Type
-> TcM Type
tc_fun_type TcTyMode
mode HsArrow GhcRn
mult LHsType GhcRn
ty1 LHsType GhcRn
ty2 Type
exp_kind
tc_hs_type TcTyMode
mode (HsOpTy XOpTy GhcRn
_ LHsType GhcRn
ty1 (L SrcSpanAnnN
_ Name
op) LHsType GhcRn
ty2) Type
exp_kind
| Name
op Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funTyConKey
= TcTyMode
-> HsArrow GhcRn
-> LHsType GhcRn
-> LHsType GhcRn
-> Type
-> TcM Type
tc_fun_type TcTyMode
mode (IsUnicodeSyntax -> HsArrow GhcRn
forall pass. IsUnicodeSyntax -> HsArrow pass
HsUnrestrictedArrow IsUnicodeSyntax
NormalSyntax) LHsType GhcRn
ty1 LHsType GhcRn
ty2 Type
exp_kind
tc_hs_type TcTyMode
mode (HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllTelescope GhcRn
tele, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
ty }) Type
exp_kind
= do { ([TcTyVarBinder]
tv_bndrs, Type
ty') <- TcTyMode
-> HsForAllTelescope GhcRn
-> TcM Type
-> TcM ([TcTyVarBinder], Type)
forall a.
TcTyMode
-> HsForAllTelescope GhcRn -> TcM a -> TcM ([TcTyVarBinder], a)
tcTKTelescope TcTyMode
mode HsForAllTelescope GhcRn
tele (TcM Type -> TcM ([TcTyVarBinder], Type))
-> TcM Type -> TcM ([TcTyVarBinder], Type)
forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty Type
exp_kind
; Type -> TcM Type
forall (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 -> Maybe (LHsContext pass)
hst_ctxt = Maybe (LHsContext GhcRn)
ctxt, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
rn_ty }) Type
exp_kind
| [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Maybe (LHsContext GhcRn) -> [LHsType GhcRn]
forall (p :: Pass).
Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
fromMaybeContext Maybe (LHsContext GhcRn)
ctxt)
= TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
rn_ty Type
exp_kind
| Type -> Bool
tcIsConstraintKind Type
exp_kind
= do { [Type]
ctxt' <- TcTyMode -> Maybe (LHsContext GhcRn) -> TcM [Type]
tc_hs_context TcTyMode
mode Maybe (LHsContext GhcRn)
ctxt
; Type
ty' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
rn_ty Type
constraintKind
; Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Type -> Type
mkPhiTy [Type]
ctxt' Type
ty') }
| Bool
otherwise
= do { [Type]
ctxt' <- TcTyMode -> Maybe (LHsContext GhcRn) -> TcM [Type]
tc_hs_context TcTyMode
mode Maybe (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
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
rn_ty) ([Type] -> Type -> Type
mkPhiTy [Type]
ctxt' Type
ty')
Type
liftedTypeKind Type
exp_kind }
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsListTy XListTy GhcRn
_ LHsType GhcRn
elt_ty) Type
exp_kind
= do { Type
tau_ty <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
elt_ty Type
liftedTypeKind
; TyCon -> TcM ()
checkWiredInTyCon TyCon
listTyCon
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty (Type -> Type
mkListTy Type
tau_ty) Type
liftedTypeKind Type
exp_kind }
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsTupleTy XTupleTy GhcRn
_ HsTupleSort
HsBoxedOrConstraintTuple [LHsType GhcRn]
hs_tys) Type
exp_kind
| Just TupleSort
tup_sort <- Type -> Maybe TupleSort
tupKindSort_maybe Type
exp_kind
= String -> SDoc -> TcM ()
traceTc String
"tc_hs_type tuple" ([GenLocated SrcSpanAnnA (HsType GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsType GhcRn)]
[LHsType GhcRn]
hs_tys) TcM () -> TcM Type -> TcM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
HsType GhcRn
-> TcTyMode -> TupleSort -> [LHsType GhcRn] -> Type -> TcM Type
tc_tuple HsType GhcRn
rn_ty TcTyMode
mode TupleSort
tup_sort [LHsType GhcRn]
hs_tys Type
exp_kind
| Bool
otherwise
= do { String -> SDoc -> TcM ()
traceTc String
"tc_hs_type tuple 2" ([GenLocated SrcSpanAnnA (HsType GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsType GhcRn)]
[LHsType GhcRn]
hs_tys)
; ([Type]
tys, [Type]
kinds) <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> TcM (Type, Type))
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) ([Type], [Type])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode) [GenLocated SrcSpanAnnA (HsType GhcRn)]
[LHsType GhcRn]
hs_tys
; [Type]
kinds <- (Type -> TcM Type) -> [Type] -> TcM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TcM Type
zonkTcType [Type]
kinds
; let (Type
arg_kind, TupleSort
tup_sort)
= case [ (Type
k,TupleSort
s) | Type
k <- [Type]
kinds
, Just TupleSort
s <- [Type -> Maybe TupleSort
tupKindSort_maybe Type
k] ] of
((Type
k,TupleSort
s) : [(Type, TupleSort)]
_) -> (Type
k,TupleSort
s)
[] -> (Type
liftedTypeKind, TupleSort
BoxedTuple)
; [Type]
tys' <- [TcM Type] -> TcM [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ SrcSpanAnnA -> TcM Type -> TcM Type
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
hs_ty Type
ty Type
kind Type
arg_kind
| ((L SrcSpanAnnA
loc HsType GhcRn
hs_ty),Type
ty,Type
kind) <- [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [Type]
-> [Type]
-> [(GenLocated SrcSpanAnnA (HsType GhcRn), Type, Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [GenLocated SrcSpanAnnA (HsType GhcRn)]
[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' ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
forall a b. a -> b -> a
const Type
arg_kind) [Type]
tys') Type
exp_kind }
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsTupleTy XTupleTy GhcRn
_ HsTupleSort
HsUnboxedTuple [LHsType GhcRn]
tys) Type
exp_kind
= HsType GhcRn
-> TcTyMode -> TupleSort -> [LHsType GhcRn] -> Type -> TcM Type
tc_tuple HsType GhcRn
rn_ty TcTyMode
mode TupleSort
UnboxedTuple [LHsType GhcRn]
tys Type
exp_kind
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsSumTy XSumTy GhcRn
_ [LHsType GhcRn]
hs_tys) Type
exp_kind
= do { let arity :: Arity
arity = [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [GenLocated SrcSpanAnnA (HsType GhcRn)]
[LHsType GhcRn]
hs_tys
; [Type]
arg_kinds <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> TcM Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> TcM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\GenLocated SrcSpanAnnA (HsType GhcRn)
_ -> TcM Type
newOpenTypeKind) [GenLocated SrcSpanAnnA (HsType GhcRn)]
[LHsType GhcRn]
hs_tys
; [Type]
tau_tys <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> Type -> TcM Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> [Type] -> TcM [Type]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode) [GenLocated SrcSpanAnnA (HsType GhcRn)]
[LHsType GhcRn]
hs_tys [Type]
arg_kinds
; let arg_reps :: [Type]
arg_reps = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Type -> Type
Type -> Type
kindRep [Type]
arg_kinds
arg_tys :: [Type]
arg_tys = [Type]
arg_reps [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
tau_tys
sum_ty :: Type
sum_ty = TyCon -> [Type] -> Type
mkTyConApp (Arity -> TyCon
sumTyCon Arity
arity) [Type]
arg_tys
sum_kind :: Type
sum_kind = [Type] -> Type
unboxedSumKind [Type]
arg_reps
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty Type
sum_ty Type
sum_kind Type
exp_kind
}
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsExplicitListTy XExplicitListTy GhcRn
_ PromotionFlag
_ [LHsType GhcRn]
tys) Type
exp_kind
= do { [(Type, Type)]
tks <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> TcM (Type, Type))
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> IOEnv (Env TcGblEnv TcLclEnv) [(Type, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode) [GenLocated SrcSpanAnnA (HsType GhcRn)]
[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 = ((Type -> Type -> Type) -> Type -> [Type] -> Type
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
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty Type
ty (Type -> Type
mkListTy Type
kind) Type
exp_kind }
where
mk_cons :: Type -> Type -> Type -> Type
mk_cons Type
k Type
a Type
b = TyCon -> [Type] -> Type
mkTyConApp (DataCon -> TyCon
promoteDataCon DataCon
consDataCon) [Type
k, Type
a, Type
b]
mk_nil :: Type -> Type
mk_nil Type
k = TyCon -> [Type] -> Type
mkTyConApp (DataCon -> TyCon
promoteDataCon DataCon
nilDataCon) [Type
k]
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsExplicitTupleTy XExplicitTupleTy GhcRn
_ [LHsType GhcRn]
tys) Type
exp_kind
= do { [Type]
ks <- Arity -> TcM Type -> TcM [Type]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
arity TcM Type
newMetaKindVar
; [Type]
taus <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> Type -> TcM Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> [Type] -> TcM [Type]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode) [GenLocated SrcSpanAnnA (HsType GhcRn)]
[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
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty (TyCon -> [Type] -> Type
mkTyConApp TyCon
ty_con ([Type]
ks [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
taus)) Type
tup_k Type
exp_kind }
where
arity :: Arity
arity = [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [GenLocated SrcSpanAnnA (HsType GhcRn)]
[LHsType GhcRn]
tys
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsIParamTy XIParamTy GhcRn
_ (L SrcSpan
_ HsIPName
n) LHsType GhcRn
ty) Type
exp_kind
= do { MASSERT( isTypeLevel (mode_tyki mode) )
; Type
ty' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty Type
liftedTypeKind
; let n' :: Type
n' = FastString -> Type
mkStrLitTy (FastString -> Type) -> FastString -> Type
forall a b. (a -> b) -> a -> b
$ HsIPName -> FastString
hsIPNameFS HsIPName
n
; Class
ipClass <- Name -> TcM Class
tcLookupClass Name
ipClassName
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty (Class -> [Type] -> Type
mkClassPred Class
ipClass [Type
n',Type
ty'])
Type
constraintKind Type
exp_kind }
tc_hs_type TcTyMode
_ rn_ty :: HsType GhcRn
rn_ty@(HsStarTy XStarTy GhcRn
_ Bool
_) Type
exp_kind
= HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty Type
liftedTypeKind Type
liftedTypeKind Type
exp_kind
tc_hs_type TcTyMode
_ rn_ty :: HsType GhcRn
rn_ty@(HsTyLit XTyLit GhcRn
_ (HsNumTy SourceText
_ Integer
n)) Type
exp_kind
= do { TyCon -> TcM ()
checkWiredInTyCon TyCon
naturalTyCon
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty (Integer -> Type
mkNumLitTy Integer
n) Type
naturalTy Type
exp_kind }
tc_hs_type TcTyMode
_ rn_ty :: HsType GhcRn
rn_ty@(HsTyLit XTyLit GhcRn
_ (HsStrTy SourceText
_ FastString
s)) Type
exp_kind
= do { TyCon -> TcM ()
checkWiredInTyCon TyCon
typeSymbolKindCon
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty (FastString -> Type
mkStrLitTy FastString
s) Type
typeSymbolKind Type
exp_kind }
tc_hs_type TcTyMode
_ rn_ty :: HsType GhcRn
rn_ty@(HsTyLit XTyLit GhcRn
_ (HsCharTy SourceText
_ Char
c)) Type
exp_kind
= do { TyCon -> TcM ()
checkWiredInTyCon TyCon
charTyCon
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty (Char -> Type
mkCharLitTy Char
c) Type
charTy Type
exp_kind }
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(HsWildCardTy XWildCardTy GhcRn
_) Type
ek
= IsExtraConstraint -> TcTyMode -> HsType GhcRn -> Type -> TcM Type
tcAnonWildCardOcc IsExtraConstraint
NoExtraConstraint TcTyMode
mode HsType GhcRn
ty Type
ek
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(HsTyVar {}) Type
ek = HasDebugCallStack => TcTyMode -> HsType GhcRn -> Type -> TcM Type
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_infer_hs_type_ek TcTyMode
mode HsType GhcRn
ty Type
ek
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(HsAppTy {}) Type
ek = HasDebugCallStack => TcTyMode -> HsType GhcRn -> Type -> TcM Type
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_infer_hs_type_ek TcTyMode
mode HsType GhcRn
ty Type
ek
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(HsAppKindTy{}) Type
ek = HasDebugCallStack => TcTyMode -> HsType GhcRn -> Type -> TcM Type
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_infer_hs_type_ek TcTyMode
mode HsType GhcRn
ty Type
ek
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(HsOpTy {}) Type
ek = HasDebugCallStack => TcTyMode -> HsType GhcRn -> Type -> TcM Type
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_infer_hs_type_ek TcTyMode
mode HsType GhcRn
ty Type
ek
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(HsKindSig {}) Type
ek = HasDebugCallStack => TcTyMode -> HsType GhcRn -> Type -> TcM Type
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_infer_hs_type_ek TcTyMode
mode HsType GhcRn
ty Type
ek
tc_hs_type TcTyMode
mode ty :: HsType GhcRn
ty@(XHsType {}) Type
ek = HasDebugCallStack => TcTyMode -> HsType GhcRn -> Type -> TcM Type
TcTyMode -> HsType GhcRn -> Type -> TcM Type
tc_infer_hs_type_ek TcTyMode
mode HsType GhcRn
ty Type
ek
tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult
tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Type
tc_mult TcTyMode
mode HsArrow GhcRn
ty = TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode (HsArrow GhcRn -> LHsType GhcRn
arrowToHsType HsArrow GhcRn
ty) Type
multiplicityTy
tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind
-> TcM TcType
tc_fun_type :: TcTyMode
-> HsArrow GhcRn
-> LHsType GhcRn
-> LHsType GhcRn
-> Type
-> TcM Type
tc_fun_type TcTyMode
mode HsArrow GhcRn
mult LHsType GhcRn
ty1 LHsType GhcRn
ty2 Type
exp_kind = case TcTyMode -> TypeOrKind
mode_tyki TcTyMode
mode of
TypeOrKind
TypeLevel ->
do { Type
arg_k <- TcM Type
newOpenTypeKind
; Type
res_k <- TcM Type
newOpenTypeKind
; Type
ty1' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty1 Type
arg_k
; Type
ty2' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty2 Type
res_k
; Type
mult' <- TcTyMode -> HsArrow GhcRn -> TcM Type
tc_mult TcTyMode
mode HsArrow GhcRn
mult
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (XFunTy GhcRn
-> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcRn
forall a. EpAnn a
noAnn HsArrow GhcRn
mult LHsType GhcRn
ty1 LHsType GhcRn
ty2) (Type -> Type -> Type -> Type
mkVisFunTy Type
mult' Type
ty1' Type
ty2')
Type
liftedTypeKind Type
exp_kind }
TypeOrKind
KindLevel ->
do { Type
ty1' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty1 Type
liftedTypeKind
; Type
ty2' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
ty2 Type
liftedTypeKind
; Type
mult' <- TcTyMode -> HsArrow GhcRn -> TcM Type
tc_mult TcTyMode
mode HsArrow GhcRn
mult
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (XFunTy GhcRn
-> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcRn
forall a. EpAnn a
noAnn HsArrow GhcRn
mult LHsType GhcRn
ty1 LHsType GhcRn
ty2) (Type -> Type -> Type -> Type
mkVisFunTy Type
mult' Type
ty1' Type
ty2')
Type
liftedTypeKind Type
exp_kind }
tupKindSort_maybe :: TcKind -> Maybe TupleSort
tupKindSort_maybe :: Type -> Maybe TupleSort
tupKindSort_maybe Type
k
| Just (Type
k', Coercion
_) <- Type -> Maybe (Type, Coercion)
splitCastTy_maybe Type
k = Type -> Maybe TupleSort
tupKindSort_maybe Type
k'
| Just Type
k' <- Type -> Maybe Type
tcView Type
k = Type -> Maybe TupleSort
tupKindSort_maybe Type
k'
| Type -> Bool
tcIsConstraintKind Type
k = TupleSort -> Maybe TupleSort
forall a. a -> Maybe a
Just TupleSort
ConstraintTuple
| Type -> Bool
tcIsLiftedTypeKind Type
k = TupleSort -> Maybe TupleSort
forall a. a -> Maybe a
Just TupleSort
BoxedTuple
| Bool
otherwise = Maybe TupleSort
forall a. Maybe a
Nothing
tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType
tc_tuple :: HsType GhcRn
-> TcTyMode -> TupleSort -> [LHsType GhcRn] -> Type -> TcM Type
tc_tuple HsType GhcRn
rn_ty TcTyMode
mode TupleSort
tup_sort [LHsType GhcRn]
tys Type
exp_kind
= do { [Type]
arg_kinds <- case TupleSort
tup_sort of
TupleSort
BoxedTuple -> [Type] -> TcM [Type]
forall (m :: * -> *) a. Monad m => a -> m a
return (Arity -> Type -> [Type]
forall a. Arity -> a -> [a]
replicate Arity
arity Type
liftedTypeKind)
TupleSort
UnboxedTuple -> Arity -> TcM Type -> TcM [Type]
forall (m :: * -> *) a. Applicative m => Arity -> m a -> m [a]
replicateM Arity
arity TcM Type
newOpenTypeKind
TupleSort
ConstraintTuple -> [Type] -> TcM [Type]
forall (m :: * -> *) a. Monad m => a -> m a
return (Arity -> Type -> [Type]
forall a. Arity -> a -> [a]
replicate Arity
arity Type
constraintKind)
; [Type]
tau_tys <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> Type -> TcM Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> [Type] -> TcM [Type]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode) [GenLocated SrcSpanAnnA (HsType GhcRn)]
[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 = [GenLocated SrcSpanAnnA (HsType GhcRn)] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [GenLocated SrcSpanAnnA (HsType GhcRn)]
[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" (TupleSort -> SDoc
forall a. Outputable a => a -> SDoc
ppr TupleSort
tup_sort SDoc -> SDoc -> SDoc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tau_kinds SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp_kind)
case TupleSort
tup_sort of
TupleSort
ConstraintTuple
| [Type
tau_ty] <- [Type]
tau_tys
-> Type -> Type -> TcM Type
check_expected_kind Type
tau_ty Type
constraintKind
| Bool
otherwise
-> do let tycon :: TyCon
tycon = Arity -> TyCon
cTupleTyCon Arity
arity
Arity -> TcM ()
checkCTupSize Arity
arity
Type -> Type -> TcM Type
check_expected_kind (TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type]
tau_tys) Type
constraintKind
TupleSort
BoxedTuple -> do
let tycon :: TyCon
tycon = Boxity -> Arity -> TyCon
tupleTyCon Boxity
Boxed Arity
arity
Arity -> TcM ()
checkTupSize Arity
arity
TyCon -> TcM ()
checkWiredInTyCon TyCon
tycon
Type -> Type -> TcM Type
check_expected_kind (TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type]
tau_tys) Type
liftedTypeKind
TupleSort
UnboxedTuple -> do
let tycon :: TyCon
tycon = Boxity -> Arity -> TyCon
tupleTyCon Boxity
Unboxed Arity
arity
tau_reps :: [Type]
tau_reps = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Type -> Type
Type -> Type
kindRep [Type]
tau_kinds
arg_tys :: [Type]
arg_tys = [Type]
tau_reps [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
tau_tys
res_kind :: Type
res_kind = [Type] -> Type
unboxedTupleKind [Type]
tau_reps
Arity -> TcM ()
checkTupSize Arity
arity
Type -> Type -> TcM Type
check_expected_kind (TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type]
arg_tys) Type
res_kind
where
arity :: Arity
arity = [Type] -> Arity
forall (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
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
rn_ty Type
ty Type
act_kind Type
exp_kind
splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])
splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, HsTyPats GhcRn)
splitHsAppTys HsType GhcRn
hs_ty
| HsType GhcRn -> Bool
is_app HsType GhcRn
hs_ty = (GenLocated SrcSpanAnnA (HsType GhcRn),
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))])
-> Maybe
(GenLocated SrcSpanAnnA (HsType GhcRn),
[HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))])
forall a. a -> Maybe a
Just (LHsType GhcRn -> HsTyPats GhcRn -> (LHsType GhcRn, HsTyPats GhcRn)
go (HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall a an. a -> LocatedAn an a
noLocA HsType GhcRn
hs_ty) [])
| Bool
otherwise = Maybe (LHsType GhcRn, HsTyPats GhcRn)
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
_ LHsType GhcRn
_ (L SrcSpanAnnN
_ Name
op) LHsType GhcRn
_) = Bool -> Bool
not (Name
op Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funTyConKey)
is_app (HsTyVar {}) = Bool
True
is_app (HsParTy XParTy GhcRn
_ (L SrcSpanAnnA
_ HsType GhcRn
ty)) = HsType GhcRn -> Bool
is_app HsType GhcRn
ty
is_app HsType GhcRn
_ = Bool
False
go :: LHsType GhcRn
-> [HsArg (LHsType GhcRn) (LHsKind GhcRn)]
-> (LHsType GhcRn,
[HsArg (LHsType GhcRn) (LHsKind GhcRn)])
go :: LHsType GhcRn -> HsTyPats GhcRn -> (LHsType GhcRn, HsTyPats GhcRn)
go (L SrcSpanAnnA
_ (HsAppTy XAppTy GhcRn
_ LHsType GhcRn
f LHsType GhcRn
a)) HsTyPats GhcRn
as = LHsType GhcRn -> HsTyPats GhcRn -> (LHsType GhcRn, HsTyPats GhcRn)
go LHsType GhcRn
f (GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
forall tm ty. tm -> HsArg tm ty
HsValArg GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
a HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a. a -> [a] -> [a]
: [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
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 (SrcSpan
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
XAppKindTy GhcRn
l GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
k HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a. a -> [a] -> [a]
: [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
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 (SrcSpan
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
sp) HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a. a -> [a] -> [a]
: [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
HsTyPats GhcRn
as)
go (L SrcSpanAnnA
_ (HsOpTy XOpTy GhcRn
_ LHsType GhcRn
l op :: LIdP GhcRn
op@(L SrcSpanAnnN
sp Name
_) LHsType GhcRn
r)) HsTyPats GhcRn
as
= ( SrcSpanAnnA
-> HsType GhcRn -> GenLocated SrcSpanAnnA (HsType GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnN -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la SrcSpanAnnN
sp) (XTyVar GhcRn -> PromotionFlag -> LIdP GhcRn -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcRn
forall a. EpAnn a
noAnn PromotionFlag
NotPromoted LIdP GhcRn
op)
, GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
forall tm ty. tm -> HsArg tm ty
HsValArg GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
l HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a. a -> [a] -> [a]
: GenLocated SrcSpanAnnA (HsType GhcRn)
-> HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
forall tm ty. tm -> HsArg tm ty
HsValArg GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
r HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a. a -> [a] -> [a]
: [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
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
mode (L SrcSpanAnnA
_ (HsTyVar XTyVar GhcRn
_ PromotionFlag
_ (L SrcSpanAnnN
_ Name
tv)))
= TcTyMode -> Name -> TcM (Type, Type)
tcTyVar TcTyMode
mode Name
tv
tcInferTyAppHead TcTyMode
mode LHsType GhcRn
ty
= TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode LHsType GhcRn
ty
tcInferTyApps, tcInferTyApps_nosat
:: TcTyMode
-> LHsType GhcRn
-> TcType
-> [LHsTypeArg GhcRn]
-> TcM (TcType, TcKind)
tcInferTyApps :: TcTyMode
-> LHsType GhcRn -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
tcInferTyApps TcTyMode
mode LHsType GhcRn
hs_ty Type
fun HsTyPats GhcRn
hs_args
= do { (Type
f_args, Type
res_k) <- TcTyMode
-> LHsType GhcRn -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
tcInferTyApps_nosat TcTyMode
mode LHsType GhcRn
hs_ty Type
fun HsTyPats GhcRn
hs_args
; Type -> Type -> TcM (Type, Type)
saturateFamApp Type
f_args Type
res_k }
tcInferTyApps_nosat :: TcTyMode
-> LHsType GhcRn -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
tcInferTyApps_nosat TcTyMode
mode LHsType GhcRn
orig_hs_ty Type
fun HsTyPats GhcRn
orig_hs_args
= do { String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps {" (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
orig_hs_ty SDoc -> SDoc -> SDoc
$$ [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
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 [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
HsTyPats GhcRn
orig_hs_args
; String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps }" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
f_args SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
res_k)
; (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
f_args, Type
res_k) }
where
go_init :: Arity
-> Type
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcM (Type, Type)
go_init Arity
n Type
fun [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
all_args
= Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n Type
fun TCvSubst
empty_subst Type
fun_ki [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
HsTyPats GhcRn
all_args
where
fun_ki :: Type
fun_ki = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
fun
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (InScopeSet -> TCvSubst) -> InScopeSet -> TCvSubst
forall a b. (a -> b) -> a -> b
$ VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$
Type -> VarSet
tyCoVarsOfType Type
fun_ki
go :: Int
-> TcType
-> TCvSubst
-> TcKind
-> [LHsTypeArg GhcRn]
-> TcM (TcType, TcKind)
go :: Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n Type
fun TCvSubst
subst Type
fun_ki HsTyPats GhcRn
all_args = case ([HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
HsTyPats GhcRn
all_args, Type -> Maybe (TyBinder, Type)
tcSplitPiTy_maybe Type
fun_ki) of
([], Maybe (TyBinder, Type)
_) -> (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
fun, HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
fun_ki)
(HsArgPar SrcSpan
_ : [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
args, Maybe (TyBinder, Type)
_) -> Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n Type
fun TCvSubst
subst Type
fun_ki [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
HsTyPats GhcRn
args
(HsTypeArg SrcSpan
_ GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ki_arg : [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
hs_args, Just (TyBinder
ki_binder, Type
inner_ki)) ->
case TyBinder
ki_binder of
Named (Bndr TyVar
_ ArgFlag
Inferred) -> TyBinder -> Type -> TcM (Type, Type)
instantiate TyBinder
ki_binder Type
inner_ki
Anon AnonArgFlag
InvisArg Scaled Type
_ -> TyBinder -> Type -> TcM (Type, Type)
instantiate TyBinder
ki_binder Type
inner_ki
Named (Bndr TyVar
_ ArgFlag
Specified) ->
do { String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (vis kind app)"
([SDoc] -> SDoc
vcat [ TyBinder -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyBinder
ki_binder, GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ki_arg
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyBinder -> Type
tyBinderType TyBinder
ki_binder)
, TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst ])
; let exp_kind :: Type
exp_kind = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ TyBinder -> Type
tyBinderType TyBinder
ki_binder
; TcTyMode
arg_mode <- TypeOrKind -> HoleMode -> TcM TcTyMode
mkHoleMode TypeOrKind
KindLevel HoleMode
HM_VTA
; Type
ki_arg <- SDoc -> TcM Type -> TcM Type
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn) -> Arity -> SDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Arity -> SDoc
funAppCtxt GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
orig_hs_ty GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ki_arg Arity
n) (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
arg_mode GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
hs_ki_arg Type
exp_kind
; String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (vis kind app)" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp_kind)
; (TCvSubst
subst', Type
fun') <- TCvSubst -> Type -> TyBinder -> Type -> TcM (TCvSubst, Type)
mkAppTyM TCvSubst
subst Type
fun TyBinder
ki_binder Type
ki_arg
; Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) Type
fun' TCvSubst
subst' Type
inner_ki [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
HsTyPats GhcRn
hs_args }
TyBinder
_ -> GenLocated SrcSpanAnnA (HsType GhcRn) -> Type -> TcM (Type, Type)
forall {a} {a} {a}.
(Outputable a, Outputable a) =>
a -> a -> TcRn a
ty_app_err GenLocated SrcSpanAnnA (HsType GhcRn)
hs_ki_arg (Type -> TcM (Type, Type)) -> Type -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$ HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
fun_ki
(HsTypeArg SrcSpan
_ GenLocated SrcSpanAnnA (HsType GhcRn)
ki_arg : [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
_, Maybe (TyBinder, Type)
Nothing) -> TcM (Type, Type) -> TcM (Type, Type)
try_again_after_substing_or (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
GenLocated SrcSpanAnnA (HsType GhcRn) -> Type -> TcM (Type, Type)
forall {a} {a} {a}.
(Outputable a, Outputable a) =>
a -> a -> TcRn a
ty_app_err GenLocated SrcSpanAnnA (HsType GhcRn)
ki_arg Type
substed_fun_ki
(HsValArg GenLocated SrcSpanAnnA (HsType GhcRn)
arg : [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
args, Just (TyBinder
ki_binder, Type
inner_ki))
| TyBinder -> Bool
isInvisibleBinder TyBinder
ki_binder
-> TyBinder -> Type -> TcM (Type, Type)
instantiate TyBinder
ki_binder Type
inner_ki
| Bool
otherwise
-> do { String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (vis normal app)"
([SDoc] -> SDoc
vcat [ TyBinder -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyBinder
ki_binder
, GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
arg
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyBinder -> Type
tyBinderType TyBinder
ki_binder)
, TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst ])
; let exp_kind :: Type
exp_kind = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ TyBinder -> Type
tyBinderType TyBinder
ki_binder
; Type
arg' <- SDoc -> TcM Type -> TcM Type
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (GenLocated SrcSpanAnnA (HsType GhcRn)
-> GenLocated SrcSpanAnnA (HsType GhcRn) -> Arity -> SDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Arity -> SDoc
funAppCtxt GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
orig_hs_ty GenLocated SrcSpanAnnA (HsType GhcRn)
arg Arity
n) (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
arg Type
exp_kind
; String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (vis normal app) 2" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp_kind)
; (TCvSubst
subst', Type
fun') <- TCvSubst -> Type -> TyBinder -> Type -> TcM (TCvSubst, Type)
mkAppTyM TCvSubst
subst Type
fun TyBinder
ki_binder Type
arg'
; Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
+Arity
1) Type
fun' TCvSubst
subst' Type
inner_ki [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
HsTyPats GhcRn
args }
(HsValArg GenLocated SrcSpanAnnA (HsType GhcRn)
_ : [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
_, Maybe (TyBinder, Type)
Nothing)
-> TcM (Type, Type) -> TcM (Type, Type)
try_again_after_substing_or (TcM (Type, Type) -> TcM (Type, Type))
-> TcM (Type, Type) -> TcM (Type, Type)
forall a b. (a -> b) -> a -> b
$
do { let arrows_needed :: Arity
arrows_needed = [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> Arity
forall tm ty. [HsArg tm ty] -> Arity
n_initial_val_args [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
HsTyPats GhcRn
all_args
; Coercion
co <- GenLocated SrcSpanAnnA (HsType GhcRn)
-> Arity -> Type -> TcM Coercion
forall fun. Outputable fun => fun -> Arity -> Type -> TcM Coercion
matchExpectedFunKind GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
hs_ty Arity
arrows_needed Type
substed_fun_ki
; Type
fun' <- Type -> TcM Type
zonkTcType (Type
fun Type -> Coercion -> Type
`mkTcCastTy` Coercion
co)
; String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (no binder)" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun_ki
, Arity -> SDoc
forall a. Outputable a => a -> SDoc
ppr Arity
arrows_needed
, Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun' SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
fun')]
; Arity
-> Type
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> TcM (Type, Type)
go_init Arity
n Type
fun' [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
HsTyPats GhcRn
all_args }
where
instantiate :: TyBinder -> Type -> TcM (Type, Type)
instantiate TyBinder
ki_binder Type
inner_ki
= do { String -> SDoc -> TcM ()
traceTc String
"tcInferTyApps (need to instantiate)"
([SDoc] -> SDoc
vcat [ TyBinder -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyBinder
ki_binder, TCvSubst -> SDoc
forall a. Outputable a => a -> SDoc
ppr TCvSubst
subst])
; (TCvSubst
subst', Type
arg') <- TCvSubst -> TyBinder -> TcM (TCvSubst, Type)
tcInstInvisibleTyBinder TCvSubst
subst TyBinder
ki_binder
; Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n (Type -> Type -> Type
mkAppTy Type
fun Type
arg') TCvSubst
subst' Type
inner_ki HsTyPats GhcRn
all_args }
try_again_after_substing_or :: TcM (Type, Type) -> TcM (Type, Type)
try_again_after_substing_or TcM (Type, Type)
fallthrough
| Bool -> Bool
not (TCvSubst -> Bool
isEmptyTCvSubst TCvSubst
subst)
= Arity
-> Type -> TCvSubst -> Type -> HsTyPats GhcRn -> TcM (Type, Type)
go Arity
n Type
fun TCvSubst
zapped_subst Type
substed_fun_ki HsTyPats GhcRn
all_args
| Bool
otherwise
= TcM (Type, Type)
fallthrough
zapped_subst :: TCvSubst
zapped_subst = TCvSubst -> TCvSubst
zapTCvSubst TCvSubst
subst
substed_fun_ki :: Type
substed_fun_ki = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
fun_ki
hs_ty :: LHsType GhcRn
hs_ty = LHsType GhcRn -> HsTyPats GhcRn -> LHsType GhcRn
appTypeToArg LHsType GhcRn
orig_hs_ty (Arity
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
-> [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
forall a. Arity -> [a] -> [a]
take (Arity
nArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1) [HsArg
(GenLocated SrcSpanAnnA (HsType GhcRn))
(GenLocated SrcSpanAnnA (HsType GhcRn))]
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 Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ [HsArg tm ty] -> Arity
forall tm ty. [HsArg tm ty] -> Arity
n_initial_val_args [HsArg tm ty]
args
n_initial_val_args (HsArgPar {} : [HsArg tm ty]
args) = [HsArg tm ty] -> Arity
forall tm ty. [HsArg tm ty] -> Arity
n_initial_val_args [HsArg tm ty]
args
n_initial_val_args [HsArg tm ty]
_ = Arity
0
ty_app_err :: a -> a -> TcRn a
ty_app_err a
arg a
ty
= SDoc -> TcRn a
forall a. SDoc -> TcM a
failWith (SDoc -> TcRn a) -> SDoc -> TcRn a
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Cannot apply function of kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
ty)
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"to visible kind argument" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
arg)
mkAppTyM :: TCvSubst
-> TcType -> TyCoBinder
-> TcType
-> TcM (TCvSubst, TcType)
mkAppTyM :: TCvSubst -> Type -> TyBinder -> Type -> TcM (TCvSubst, Type)
mkAppTyM TCvSubst
subst Type
fun TyBinder
ki_binder Type
arg
|
TyConApp TyCon
tc [Type]
args <- Type
fun
, TyCon -> Bool
isTypeSynonymTyCon TyCon
tc
, [Type]
args [Type] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthIs` (TyCon -> Arity
tyConArity TyCon
tc Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
1)
, (TyVar -> Bool) -> [TyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TyVar -> Bool
isTrickyTvBinder (TyCon -> [TyVar]
tyConTyVars TyCon
tc)
= do { Type
arg' <- Type -> TcM Type
zonkTcType Type
arg
; [Type]
args' <- [Type] -> TcM [Type]
zonkTcTypes [Type]
args
; let subst' :: TCvSubst
subst' = case TyBinder
ki_binder of
Anon {} -> TCvSubst
subst
Named (Bndr TyVar
tv ArgFlag
_) -> TCvSubst -> TyVar -> Type -> TCvSubst
extendTvSubstAndInScope TCvSubst
subst TyVar
tv Type
arg'
; (TCvSubst, Type) -> TcM (TCvSubst, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst', TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ([Type]
args' [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
arg'])) }
mkAppTyM TCvSubst
subst Type
fun (Anon {}) Type
arg
= (TCvSubst, Type) -> TcM (TCvSubst, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst, Type -> Type -> Type
mk_app_ty Type
fun Type
arg)
mkAppTyM TCvSubst
subst Type
fun (Named (Bndr TyVar
tv ArgFlag
_)) Type
arg
= do { Type
arg' <- if TyVar -> Bool
isTrickyTvBinder TyVar
tv
then
Type -> TcM Type
zonkTcType Type
arg
else Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
arg
; (TCvSubst, Type) -> TcM (TCvSubst, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ( TCvSubst -> TyVar -> Type -> TCvSubst
extendTvSubstAndInScope TCvSubst
subst TyVar
tv Type
arg'
, Type -> Type -> Type
mk_app_ty Type
fun Type
arg' ) }
mk_app_ty :: TcType -> TcType -> TcType
mk_app_ty :: Type -> Type -> Type
mk_app_ty Type
fun Type
arg
= ASSERT2( isPiTy fun_kind
, ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg )
Type -> Type -> Type
mkAppTy Type
fun Type
arg
where
fun_kind :: Type
fun_kind = HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
fun
isTrickyTvBinder :: TcTyVar -> Bool
isTrickyTvBinder :: TyVar -> Bool
isTrickyTvBinder TyVar
tv = Type -> Bool
isPiTy (TyVar -> Type
tyVarKind TyVar
tv)
saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind)
saturateFamApp :: Type -> Type -> TcM (Type, Type)
saturateFamApp Type
ty Type
kind
| Just (TyCon
tc, [Type]
args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
, TyCon -> Bool
mustBeSaturated TyCon
tc
, let n_to_inst :: Arity
n_to_inst = TyCon -> Arity
tyConArity TyCon
tc Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- [Type] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
args
= do { ([Type]
extra_args, Type
ki') <- Arity -> Type -> TcM ([Type], Type)
tcInstInvisibleTyBindersN Arity
n_to_inst Type
kind
; (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty Type -> [Type] -> Type
`mkTcAppTys` [Type]
extra_args, Type
ki') }
| Bool
otherwise
= (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ty, Type
kind)
appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn
appTypeToArg :: LHsType GhcRn -> HsTyPats GhcRn -> LHsType GhcRn
appTypeToArg LHsType GhcRn
f [] = LHsType GhcRn
f
appTypeToArg LHsType GhcRn
f (HsValArg LHsType GhcRn
arg : HsTyPats GhcRn
args) = LHsType GhcRn -> HsTyPats GhcRn -> LHsType GhcRn
appTypeToArg (LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
forall (p :: Pass).
LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
mkHsAppTy LHsType GhcRn
f LHsType GhcRn
arg) HsTyPats GhcRn
args
appTypeToArg LHsType GhcRn
f (HsArgPar SrcSpan
_ : HsTyPats GhcRn
args) = LHsType GhcRn -> HsTyPats GhcRn -> LHsType GhcRn
appTypeToArg LHsType GhcRn
f HsTyPats GhcRn
args
appTypeToArg LHsType GhcRn
f (HsTypeArg SrcSpan
l LHsType GhcRn
arg : HsTyPats GhcRn
args)
= LHsType GhcRn -> HsTyPats GhcRn -> LHsType GhcRn
appTypeToArg (XAppKindTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> LHsType GhcRn
forall (p :: Pass).
XAppKindTy (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
-> LHsType (GhcPass p)
mkHsAppKindTy SrcSpan
XAppKindTy GhcRn
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" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
$$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act_kind)
; ([Type]
new_args, Type
act_kind') <- Arity -> Type -> TcM ([Type], Type)
tcInstInvisibleTyBindersN Arity
n_to_inst Type
act_kind
; let origin :: CtOrigin
origin = TypeEqOrigin { uo_actual :: Type
uo_actual = Type
act_kind'
, uo_expected :: Type
uo_expected = Type
exp_kind
, uo_thing :: Maybe SDoc
uo_thing = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
hs_ty)
, uo_visible :: Bool
uo_visible = Bool
True }
; String -> SDoc -> TcM ()
traceTc String
"checkExpectedKindX" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
hs_ty
, String -> SDoc
text String
"act_kind':" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act_kind'
, String -> SDoc
text String
"exp_kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp_kind ]
; let res_ty :: Type
res_ty = Type
ty Type -> [Type] -> Type
`mkTcAppTys` [Type]
new_args
; if Type
act_kind' HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqType` Type
exp_kind
then Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
res_ty
else do { Coercion
co_k <- TypeOrKind -> CtOrigin -> Type -> Type -> TcM Coercion
uType TypeOrKind
KindLevel CtOrigin
origin Type
act_kind' Type
exp_kind
; String -> SDoc -> TcM ()
traceTc String
"checkExpectedKind" ([SDoc] -> SDoc
vcat [ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act_kind
, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp_kind
, Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co_k ])
; Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
res_ty Type -> Coercion -> Type
`mkTcCastTy` Coercion
co_k) } }
where
n_exp_invis_bndrs :: Arity
n_exp_invis_bndrs = Type -> Arity
invisibleTyBndrCount Type
exp_kind
n_act_invis_bndrs :: Arity
n_act_invis_bndrs = Type -> Arity
invisibleTyBndrCount Type
act_kind
n_to_inst :: Arity
n_to_inst = Arity
n_act_invis_bndrs Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
n_exp_invis_bndrs
tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]
tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsContext Maybe (LHsContext GhcRn)
cxt = TcTyMode -> Maybe (LHsContext GhcRn) -> TcM [Type]
tc_hs_context TcTyMode
typeLevelMode Maybe (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 -> Maybe (LHsContext GhcRn) -> TcM [PredType]
tc_hs_context :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM [Type]
tc_hs_context TcTyMode
_ Maybe (LHsContext GhcRn)
Nothing = [Type] -> TcM [Type]
forall (m :: * -> *) a. Monad m => a -> m a
return []
tc_hs_context TcTyMode
mode (Just LHsContext GhcRn
ctxt) = (GenLocated SrcSpanAnnA (HsType GhcRn) -> TcM Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> TcM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcTyMode -> LHsType GhcRn -> TcM Type
tc_lhs_pred TcTyMode
mode) (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcRn)]
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 :: TcTyMode -> Name -> TcM (TcType, TcKind)
tcTyVar :: TcTyMode -> Name -> TcM (Type, Type)
tcTyVar TcTyMode
mode Name
name
= do { String -> SDoc -> TcM ()
traceTc String
"lk1" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
; TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
name
; case TcTyThing
thing of
ATyVar Name
_ TyVar
tv -> (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Type
mkTyVarTy TyVar
tv, TyVar -> Type
tyVarKind TyVar
tv)
ATcTyCon TyCon
tc_tc
-> do { TyCon -> TcM ()
check_tc TyCon
tc_tc
; (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Type
mkTyConTy TyCon
tc_tc, TyCon -> Type
tyConKind TyCon
tc_tc) }
AGlobal (ATyCon TyCon
tc)
-> do { TyCon -> TcM ()
check_tc TyCon
tc
; (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Type
mkTyConTy TyCon
tc, TyCon -> Type
tyConKind TyCon
tc) }
AGlobal (AConLike (RealDataCon DataCon
dc))
-> do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
data_kinds Bool -> Bool -> Bool
|| DataCon -> Bool
specialPromotedDc DataCon
dc) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
Name -> PromotionErr -> TcM ()
forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name PromotionErr
NoDataKindsDC
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyCon -> Bool
isFamInstTyCon (DataCon -> TyCon
dataConTyCon DataCon
dc)) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
Name -> PromotionErr -> TcM ()
forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name PromotionErr
FamDataConPE
; let ([TyVar]
_, [TyVar]
_, [EqSpec]
_, [Type]
theta, [Scaled Type]
_, Type
_) = DataCon
-> ([TyVar], [TyVar], [EqSpec], [Type], [Scaled Type], Type)
dataConFullSig DataCon
dc
; String -> SDoc -> TcM ()
traceTc String
"tcTyVar" (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
theta SDoc -> SDoc -> SDoc
$$ Maybe Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Type] -> Maybe Type
dc_theta_illegal_constraint [Type]
theta))
; case [Type] -> Maybe Type
dc_theta_illegal_constraint [Type]
theta of
Just Type
pred -> Name -> PromotionErr -> TcM ()
forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name (PromotionErr -> TcM ()) -> PromotionErr -> TcM ()
forall a b. (a -> b) -> a -> b
$
Type -> PromotionErr
ConstrainedDataConPE Type
pred
Maybe Type
Nothing -> () -> TcM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
; let tc :: TyCon
tc = DataCon -> TyCon
promoteDataCon DataCon
dc
; (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [], TyCon -> Type
tyConKind TyCon
tc) }
APromotionErr PromotionErr
err -> Name -> PromotionErr -> TcM (Type, Type)
forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name PromotionErr
err
TcTyThing
_ -> String -> TcTyThing -> Name -> TcM (Type, Type)
forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr String
"type" TcTyThing
thing Name
name }
where
check_tc :: TyCon -> TcM ()
check_tc :: TyCon -> TcM ()
check_tc TyCon
tc = do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TypeOrKind -> Bool
isTypeLevel (TcTyMode -> TypeOrKind
mode_tyki TcTyMode
mode) Bool -> Bool -> Bool
||
Bool
data_kinds Bool -> Bool -> Bool
||
TyCon -> Bool
isKindTyCon TyCon
tc) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
Name -> PromotionErr -> TcM ()
forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name PromotionErr
NoDataKindsTC }
dc_theta_illegal_constraint :: ThetaType -> Maybe PredType
dc_theta_illegal_constraint :: [Type] -> Maybe Type
dc_theta_illegal_constraint = (Type -> Bool) -> [Type] -> Maybe Type
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Bool -> Bool
not (Bool -> Bool) -> (Type -> Bool) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Bool
isEqPred)
addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt :: forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt (L SrcSpanAnnA
_ (HsWildCardTy XWildCardTy GhcRn
_)) TcM a
thing = TcM a
thing
addTypeCtxt (L SrcSpanAnnA
_ HsType GhcRn
ty) TcM a
thing
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
doc TcM a
thing
where
doc :: SDoc
doc = String -> SDoc
text String
"In the type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
ty)
bindNamedWildCardBinders :: [Name]
-> ([(Name, TcTyVar)] -> TcM a)
-> TcM a
bindNamedWildCardBinders :: forall a. HsQTvsRn -> ([(Name, TyVar)] -> TcM a) -> TcM a
bindNamedWildCardBinders HsQTvsRn
wc_names [(Name, TyVar)] -> TcM a
thing_inside
= do { [TyVar]
wcs <- (Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> HsQTvsRn -> TcM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
newNamedWildTyVar HsQTvsRn
wc_names
; let wc_prs :: [(Name, TyVar)]
wc_prs = HsQTvsRn
wc_names HsQTvsRn -> [TyVar] -> [(Name, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
wcs
; [(Name, TyVar)] -> TcM a -> TcM a
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
wc_prs (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
[(Name, TyVar)] -> TcM a
thing_inside [(Name, TyVar)]
wc_prs }
newNamedWildTyVar :: Name -> TcM TcTyVar
newNamedWildTyVar :: Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
newNamedWildTyVar Name
_name
= do { Type
kind <- TcM Type
newMetaKindVar
; TcTyVarDetails
details <- MetaInfo -> TcM TcTyVarDetails
newMetaDetails MetaInfo
TauTv
; Name
wc_name <- FastString -> TcM Name
newMetaTyVarName (String -> FastString
fsLit String
"w")
; let tyvar :: TyVar
tyvar = Name -> Type -> TcTyVarDetails -> TyVar
mkTcTyVar Name
wc_name Type
kind TcTyVarDetails
details
; String -> SDoc -> TcM ()
traceTc String
"newWildTyVar" (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar)
; TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
tyvar }
tcAnonWildCardOcc :: IsExtraConstraint
-> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType
tcAnonWildCardOcc :: IsExtraConstraint -> TcTyMode -> HsType GhcRn -> Type -> TcM Type
tcAnonWildCardOcc IsExtraConstraint
is_extra (TcTyMode { mode_holes :: TcTyMode -> HoleInfo
mode_holes = Just (TcLevel
hole_lvl, HoleMode
hole_mode) })
HsType GhcRn
ty Type
exp_kind
= do { TcTyVarDetails
kv_details <- TcLevel -> TcM TcTyVarDetails
newTauTvDetailsAtLevel TcLevel
hole_lvl
; Name
kv_name <- FastString -> TcM Name
newMetaTyVarName (String -> FastString
fsLit String
"k")
; TcTyVarDetails
wc_details <- TcLevel -> TcM TcTyVarDetails
newTauTvDetailsAtLevel TcLevel
hole_lvl
; Name
wc_name <- FastString -> TcM Name
newMetaTyVarName (String -> FastString
fsLit String
wc_nm)
; let kv :: TyVar
kv = Name -> Type -> TcTyVarDetails -> TyVar
mkTcTyVar Name
kv_name Type
liftedTypeKind TcTyVarDetails
kv_details
wc_kind :: Type
wc_kind = TyVar -> Type
mkTyVarTy TyVar
kv
wc_tv :: TyVar
wc_tv = Name -> Type -> TcTyVarDetails -> TyVar
mkTcTyVar Name
wc_name Type
wc_kind TcTyVarDetails
wc_details
; String -> SDoc -> TcM ()
traceTc String
"tcAnonWildCardOcc" (TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
hole_lvl SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
emit_holes)
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
emit_holes (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
IsExtraConstraint -> TyVar -> TcM ()
emitAnonTypeHole IsExtraConstraint
is_extra TyVar
wc_tv
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
ty (TyVar -> Type
mkTyVarTy TyVar
wc_tv) Type
wc_kind Type
exp_kind }
where
wc_nm :: String
wc_nm = case HoleMode
hole_mode of
HoleMode
HM_Sig -> String
"w"
HoleMode
HM_FamPat -> String
"_"
HoleMode
HM_VTA -> String
"w"
HoleMode
HM_TyAppPat -> String
"_"
emit_holes :: Bool
emit_holes = case HoleMode
hole_mode of
HoleMode
HM_Sig -> Bool
True
HoleMode
HM_FamPat -> Bool
False
HoleMode
HM_VTA -> Bool
False
HoleMode
HM_TyAppPat -> Bool
False
tcAnonWildCardOcc IsExtraConstraint
_ TcTyMode
mode HsType GhcRn
ty Type
_
= String -> SDoc -> TcM Type
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcWildCardOcc" (TcTyMode -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyMode
mode SDoc -> SDoc -> SDoc
$$ HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
ty)
data InitialKindStrategy
= InitialKindCheck SAKS_or_CUSK
| InitialKindInfer
data SAKS_or_CUSK
= SAKS Kind
| CUSK
instance Outputable SAKS_or_CUSK where
ppr :: SAKS_or_CUSK -> SDoc
ppr (SAKS Type
k) = String -> SDoc
text String
"SAKS" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
k
ppr SAKS_or_CUSK
CUSK = String -> SDoc
text String
"CUSK"
kcDeclHeader
:: InitialKindStrategy
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TcTyCon
(InitialKindCheck SAKS_or_CUSK
msig) = SAKS_or_CUSK
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TyCon
kcCheckDeclHeader SAKS_or_CUSK
msig
kcDeclHeader InitialKindStrategy
InitialKindInfer = Name
-> TyConFlavour -> LHsQTyVars GhcRn -> TcM ContextKind -> TcM TyCon
kcInferDeclHeader
kcCheckDeclHeader
:: SAKS_or_CUSK
-> Name
-> TyConFlavour
-> LHsQTyVars GhcRn
-> TcM ContextKind
-> TcM TcTyCon
(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 TcTyCon
Name
name TyConFlavour
flav
(HsQTvs { hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass
hsq_ext = XHsQTvs GhcRn
kv_ns
, hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsq_explicit = [LHsTyVarBndr () GhcRn]
hs_tvs }) TcM ContextKind
kc_res_ki
= Name -> TyConFlavour -> TcM TyCon -> TcM TyCon
forall a. Name -> TyConFlavour -> TcM a -> TcM a
addTyConFlavCtxt Name
name TyConFlavour
flav (TcM TyCon -> TcM TyCon) -> TcM TyCon -> TcM TyCon
forall a b. (a -> b) -> a -> b
$
do { (TcLevel
tclvl, WantedConstraints
wanted, ([TyVar]
scoped_kvs, ([TyVar]
tc_tvs, Type
res_kind)))
<- String
-> TcM ([TyVar], ([TyVar], Type))
-> TcM (TcLevel, WantedConstraints, ([TyVar], ([TyVar], Type)))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"kcCheckDeclHeader_cusk" (TcM ([TyVar], ([TyVar], Type))
-> TcM (TcLevel, WantedConstraints, ([TyVar], ([TyVar], Type))))
-> TcM ([TyVar], ([TyVar], Type))
-> TcM (TcLevel, WantedConstraints, ([TyVar], ([TyVar], Type)))
forall a b. (a -> b) -> a -> b
$
HsQTvsRn -> TcM ([TyVar], Type) -> TcM ([TyVar], ([TyVar], Type))
forall a. HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Skol HsQTvsRn
XHsQTvs GhcRn
kv_ns (TcM ([TyVar], Type) -> TcM ([TyVar], ([TyVar], Type)))
-> TcM ([TyVar], Type) -> TcM ([TyVar], ([TyVar], Type))
forall a b. (a -> b) -> a -> b
$
ContextKind
-> [LHsTyVarBndr () GhcRn] -> TcM Type -> TcM ([TyVar], Type)
forall a.
ContextKind -> [LHsTyVarBndr () GhcRn] -> TcM a -> TcM ([TyVar], a)
bindExplicitTKBndrs_Q_Skol ContextKind
ctxt_kind [LHsTyVarBndr () GhcRn]
hs_tvs (TcM Type -> TcM ([TyVar], Type))
-> TcM Type -> TcM ([TyVar], Type)
forall a b. (a -> b) -> a -> b
$
ContextKind -> TcM Type
newExpectedKind (ContextKind -> TcM Type) -> TcM ContextKind -> TcM Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TcM ContextKind
kc_res_ki
; let spec_req_tkvs :: [TyVar]
spec_req_tkvs = [TyVar]
scoped_kvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
tc_tvs
all_kinds :: [Type]
all_kinds = Type
res_kind Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (TyVar -> Type) -> [TyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
tyVarKind [TyVar]
spec_req_tkvs
; CandidatesQTvs
candidates' <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfKinds [Type]
all_kinds
; let non_tc_candidates :: [TyVar]
non_tc_candidates = (TyVar -> Bool) -> [TyVar] -> [TyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (TyVar -> Bool) -> TyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Bool
isTcTyVar) (VarSet -> [TyVar]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet ([Type] -> VarSet
tyCoVarsOfTypes [Type]
all_kinds))
candidates :: CandidatesQTvs
candidates = CandidatesQTvs
candidates' { dv_kvs :: DTyVarSet
dv_kvs = CandidatesQTvs -> DTyVarSet
dv_kvs CandidatesQTvs
candidates' DTyVarSet -> [TyVar] -> DTyVarSet
`extendDVarSetList` [TyVar]
non_tc_candidates }
inf_candidates :: CandidatesQTvs
inf_candidates = CandidatesQTvs
candidates CandidatesQTvs -> [TyVar] -> CandidatesQTvs
`delCandidates` [TyVar]
spec_req_tkvs
; [TyVar]
inferred <- CandidatesQTvs -> TcM [TyVar]
quantifyTyVars CandidatesQTvs
inf_candidates
; [TyVar]
scoped_kvs <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TyVar] -> TcM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
zonkTyCoVarKind [TyVar]
scoped_kvs
; [TyVar]
tc_tvs <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TyVar] -> TcM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
zonkTyCoVarKind [TyVar]
tc_tvs
; Type
res_kind <- Type -> TcM Type
zonkTcType Type
res_kind
; let mentioned_kv_set :: VarSet
mentioned_kv_set = CandidatesQTvs -> VarSet
candidateKindVars CandidatesQTvs
candidates
specified :: [TyVar]
specified = [TyVar] -> [TyVar]
scopedSort [TyVar]
scoped_kvs
final_tc_binders :: [TyConBinder]
final_tc_binders = ArgFlag -> [TyVar] -> [TyConBinder]
mkNamedTyConBinders ArgFlag
Inferred [TyVar]
inferred
[TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
++ ArgFlag -> [TyVar] -> [TyConBinder]
mkNamedTyConBinders ArgFlag
Specified [TyVar]
specified
[TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
++ (TyVar -> TyConBinder) -> [TyVar] -> [TyConBinder]
forall a b. (a -> b) -> [a] -> [b]
map (VarSet -> TyVar -> TyConBinder
mkRequiredTyConBinder VarSet
mentioned_kv_set) [TyVar]
tc_tvs
all_tv_prs :: [(Name, TyVar)]
all_tv_prs = [TyVar] -> [(Name, TyVar)]
mkTyVarNamePairs ([TyVar]
scoped_kvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
tc_tvs)
tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Type
-> [(Name, TyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon Name
name [TyConBinder]
final_tc_binders Type
res_kind [(Name, TyVar)]
all_tv_prs
Bool
True
TyConFlavour
flav
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcM ()
reportUnsolvedEqualities SkolemInfo
skol_info ([TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
final_tc_binders)
TcLevel
tclvl WantedConstraints
wanted
; TyCon -> TcM ()
checkTyConTelescope TyCon
tycon
; String -> SDoc -> TcM ()
traceTc String
"kcCheckDeclHeader_cusk " (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"name" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
, String -> SDoc
text String
"kv_ns" SDoc -> SDoc -> SDoc
<+> HsQTvsRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsQTvsRn
XHsQTvs GhcRn
kv_ns
, String -> SDoc
text String
"hs_tvs" SDoc -> SDoc -> SDoc
<+> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
[LHsTyVarBndr () GhcRn]
hs_tvs
, String -> SDoc
text String
"scoped_kvs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
scoped_kvs
, String -> SDoc
text String
"tc_tvs" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tc_tvs
, String -> SDoc
text String
"res_kind" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
res_kind
, String -> SDoc
text String
"candidates" SDoc -> SDoc -> SDoc
<+> CandidatesQTvs -> SDoc
forall a. Outputable a => a -> SDoc
ppr CandidatesQTvs
candidates
, String -> SDoc
text String
"inferred" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
inferred
, String -> SDoc
text String
"specified" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
specified
, String -> SDoc
text String
"final_tc_binders" SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
final_tc_binders
, String -> SDoc
text String
"mkTyConKind final_tc_bndrs res_kind"
SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([TyConBinder] -> Type -> Type
mkTyConKind [TyConBinder]
final_tc_binders Type
res_kind)
, String -> SDoc
text String
"all_tv_prs" SDoc -> SDoc -> SDoc
<+> [(Name, TyVar)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
all_tv_prs ]
; TyCon -> TcM TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon }
where
skol_info :: SkolemInfo
skol_info = TyConFlavour -> Name -> SkolemInfo
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 TcTyCon
Name
name TyConFlavour
flav
(HsQTvs { hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass
hsq_ext = XHsQTvs GhcRn
kv_ns
, hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsq_explicit = [LHsTyVarBndr () GhcRn]
hs_tvs }) TcM ContextKind
kc_res_ki
= Name -> TyConFlavour -> TcM TyCon -> TcM TyCon
forall a. Name -> TyConFlavour -> TcM a -> TcM a
addTyConFlavCtxt Name
name TyConFlavour
flav (TcM TyCon -> TcM TyCon) -> TcM TyCon -> TcM TyCon
forall a b. (a -> b) -> a -> b
$
do { ([TyVar]
scoped_kvs, ([TyVar]
tc_tvs, Type
res_kind))
<- HsQTvsRn -> TcM ([TyVar], Type) -> TcM ([TyVar], ([TyVar], Type))
forall a. HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Tv HsQTvsRn
XHsQTvs GhcRn
kv_ns (TcM ([TyVar], Type) -> TcM ([TyVar], ([TyVar], Type)))
-> TcM ([TyVar], Type) -> TcM ([TyVar], ([TyVar], Type))
forall a b. (a -> b) -> a -> b
$
ContextKind
-> [LHsTyVarBndr () GhcRn] -> TcM Type -> TcM ([TyVar], Type)
forall a.
ContextKind -> [LHsTyVarBndr () GhcRn] -> TcM a -> TcM ([TyVar], a)
bindExplicitTKBndrs_Q_Tv ContextKind
ctxt_kind [LHsTyVarBndr () GhcRn]
hs_tvs (TcM Type -> TcM ([TyVar], Type))
-> TcM Type -> TcM ([TyVar], Type)
forall a b. (a -> b) -> a -> b
$
ContextKind -> TcM Type
newExpectedKind (ContextKind -> TcM Type) -> TcM ContextKind -> TcM Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TcM ContextKind
kc_res_ki
; let
tc_binders :: [TyConBinder]
tc_binders = AnonArgFlag -> [TyVar] -> [TyConBinder]
mkAnonTyConBinders AnonArgFlag
VisArg [TyVar]
tc_tvs
all_tv_prs :: [(Name, TyVar)]
all_tv_prs = [TyVar] -> [(Name, TyVar)]
mkTyVarNamePairs ([TyVar]
scoped_kvs [TyVar] -> [TyVar] -> [TyVar]
forall a. [a] -> [a] -> [a]
++ [TyVar]
tc_tvs)
tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Type
-> [(Name, TyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon Name
name [TyConBinder]
tc_binders Type
res_kind [(Name, TyVar)]
all_tv_prs
Bool
False
TyConFlavour
flav
; String -> SDoc -> TcM ()
traceTc String
"kcInferDeclHeader: not-cusk" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, HsQTvsRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsQTvsRn
XHsQTvs GhcRn
kv_ns, [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
[LHsTyVarBndr () GhcRn]
hs_tvs
, [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
scoped_kvs
, [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tc_tvs, Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([TyConBinder] -> Type -> Type
mkTyConKind [TyConBinder]
tc_binders Type
res_kind) ]
; TyCon -> TcM TyCon
forall (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 TcTyCon
Type
kisig 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]
explicit_nms }) TcM ContextKind
kc_res_ki
= Name -> TyConFlavour -> TcM TyCon -> TcM TyCon
forall a. Name -> TyConFlavour -> TcM a -> TcM a
addTyConFlavCtxt Name
name TyConFlavour
flav (TcM TyCon -> TcM TyCon) -> TcM TyCon -> TcM TyCon
forall a b. (a -> b) -> a -> b
$
do {
let ([ZippedBinder]
zipped_binders, [LHsTyVarBndr () GhcRn]
excess_bndrs, Type
kisig') = Type
-> [LHsTyVarBndr () GhcRn]
-> ([ZippedBinder], [LHsTyVarBndr () GhcRn], Type)
zipBinders Type
kisig [LHsTyVarBndr () GhcRn]
explicit_nms
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
[LHsTyVarBndr () GhcRn]
excess_bndrs) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc (Type -> [LHsTyVarBndr () GhcRn] -> SDoc
tooManyBindersErr Type
kisig' [LHsTyVarBndr () GhcRn]
excess_bndrs)
; ([TyConBinder]
vis_tcbs, [[(Name, TyVar)]] -> [(Name, TyVar)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat -> [(Name, TyVar)]
explicit_tv_prs) <- (ZippedBinder
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)]))
-> [ZippedBinder]
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyConBinder], [[(Name, TyVar)]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ZippedBinder
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)])
zipped_to_tcb [ZippedBinder]
zipped_binders
; (TcLevel
tclvl, WantedConstraints
wanted, ([TyVar]
implicit_tvs, ([TyBinder]
invis_binders, Type
r_ki)))
<- String
-> TcM ([TyVar], ([TyBinder], Type))
-> TcM (TcLevel, WantedConstraints, ([TyVar], ([TyBinder], Type)))
forall a. String -> TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndSolveEqualitiesX String
"kcCheckDeclHeader_sig" (TcM ([TyVar], ([TyBinder], Type))
-> TcM (TcLevel, WantedConstraints, ([TyVar], ([TyBinder], Type))))
-> TcM ([TyVar], ([TyBinder], Type))
-> TcM (TcLevel, WantedConstraints, ([TyVar], ([TyBinder], Type)))
forall a b. (a -> b) -> a -> b
$
HsQTvsRn
-> TcM ([TyBinder], Type) -> TcM ([TyVar], ([TyBinder], Type))
forall a. HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Tv HsQTvsRn
XHsQTvs GhcRn
implicit_nms (TcM ([TyBinder], Type) -> TcM ([TyVar], ([TyBinder], Type)))
-> TcM ([TyBinder], Type) -> TcM ([TyVar], ([TyBinder], Type))
forall a b. (a -> b) -> a -> b
$
[(Name, TyVar)] -> TcM ([TyBinder], Type) -> TcM ([TyBinder], Type)
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
explicit_tv_prs (TcM ([TyBinder], Type) -> TcM ([TyBinder], Type))
-> TcM ([TyBinder], Type) -> TcM ([TyBinder], Type)
forall a b. (a -> b) -> a -> b
$
do {
(ZippedBinder -> TcM ()) -> [ZippedBinder] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ZippedBinder -> TcM ()
check_zipped_binder [ZippedBinder]
zipped_binders
; ContextKind
ctx_k <- TcM ContextKind
kc_res_ki
; Maybe Type
m_res_ki <- case ContextKind
ctx_k of
ContextKind
AnyKind -> Maybe Type -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing
ContextKind
_ -> Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type)
-> TcM Type -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContextKind -> TcM Type
newExpectedKind ContextKind
ctx_k
; let ([TyBinder]
invis_binders, Type
r_ki) = Type -> Maybe Type -> ([TyBinder], Type)
split_invis Type
kisig' Maybe Type
m_res_ki
; Maybe Type -> (Type -> TcM ()) -> TcM ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust Maybe Type
m_res_ki ((Type -> TcM ()) -> TcM ()) -> (Type -> TcM ()) -> TcM ()
forall a b. (a -> b) -> a -> b
$ \Type
res_ki ->
TcM Coercion -> TcM ()
forall a. TcM a -> TcM ()
discardResult (TcM Coercion -> TcM ()) -> TcM Coercion -> TcM ()
forall a b. (a -> b) -> a -> b
$
Maybe SDoc -> Type -> Type -> TcM Coercion
unifyKind Maybe SDoc
forall a. Maybe a
Nothing Type
r_ki Type
res_ki
; ([TyBinder], Type) -> TcM ([TyBinder], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyBinder]
invis_binders, Type
r_ki) }
; [TyConBinder]
invis_tcbs <- (TyBinder -> IOEnv (Env TcGblEnv TcLclEnv) TyConBinder)
-> [TyBinder] -> IOEnv (Env TcGblEnv TcLclEnv) [TyConBinder]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyBinder -> IOEnv (Env TcGblEnv TcLclEnv) TyConBinder
invis_to_tcb [TyBinder]
invis_binders
; [TyVar]
implicit_tvs <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TyVar] -> TcM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
zonkTcTyVarToTyVar [TyVar]
implicit_tvs
; let tcbs :: [TyConBinder]
tcbs = [TyConBinder]
vis_tcbs [TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
++ [TyConBinder]
invis_tcbs
implicit_tv_prs :: [(Name, TyVar)]
implicit_tv_prs = HsQTvsRn
XHsQTvs GhcRn
implicit_nms HsQTvsRn -> [TyVar] -> [(Name, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
implicit_tvs
all_tv_prs :: [(Name, TyVar)]
all_tv_prs = [(Name, TyVar)]
implicit_tv_prs [(Name, TyVar)] -> [(Name, TyVar)] -> [(Name, TyVar)]
forall a. [a] -> [a] -> [a]
++ [(Name, TyVar)]
explicit_tv_prs
tc :: TyCon
tc = Name
-> [TyConBinder]
-> Type
-> [(Name, TyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon Name
name [TyConBinder]
tcbs Type
r_ki [(Name, TyVar)]
all_tv_prs Bool
True TyConFlavour
flav
skol_info :: SkolemInfo
skol_info = TyConFlavour -> Name -> SkolemInfo
TyConSkol TyConFlavour
flav Name
name
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcM ()
reportUnsolvedEqualities SkolemInfo
skol_info ([TyConBinder] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
tcbs) TcLevel
tclvl WantedConstraints
wanted
; String -> SDoc -> TcM ()
traceTc String
"kcCheckDeclHeader_sig done:" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"tyConName = " SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> Name
tyConName TyCon
tc)
, String -> SDoc
text String
"kisig =" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
debugPprType Type
kisig
, String -> SDoc
text String
"tyConKind =" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
debugPprType (TyCon -> Type
tyConKind TyCon
tc)
, String -> SDoc
text String
"tyConBinders = " SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [TyConBinder]
tyConBinders TyCon
tc)
, String -> SDoc
text String
"tcTyConScopedTyVars" SDoc -> SDoc -> SDoc
<+> [(Name, TyVar)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyCon -> [(Name, TyVar)]
tcTyConScopedTyVars TyCon
tc)
, String -> SDoc
text String
"tyConResKind" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
debugPprType (TyCon -> Type
tyConResKind TyCon
tc)
]
; TyCon -> TcM TyCon
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc }
where
zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)])
zipped_to_tcb :: ZippedBinder
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)])
zipped_to_tcb ZippedBinder
zb = case ZippedBinder
zb of
ZippedBinder (Named (Bndr TyVar
v ArgFlag
Specified)) Maybe (LHsTyVarBndr () GhcRn)
Nothing ->
(TyConBinder, [(Name, TyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)])
forall (m :: * -> *) a. Monad m => a -> m a
return (ArgFlag -> TyVar -> TyConBinder
mkNamedTyConBinder ArgFlag
Specified TyVar
v, [])
ZippedBinder (Named (Bndr TyVar
v ArgFlag
Inferred)) Maybe (LHsTyVarBndr () GhcRn)
Nothing ->
(TyConBinder, [(Name, TyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)])
forall (m :: * -> *) a. Monad m => a -> m a
return (ArgFlag -> TyVar -> TyConBinder
mkNamedTyConBinder ArgFlag
Inferred TyVar
v, [])
ZippedBinder (Anon AnonArgFlag
InvisArg Scaled Type
bndr_ki) Maybe (LHsTyVarBndr () GhcRn)
Nothing -> do
Name
name <- OccName -> TcM Name
forall gbl lcl. OccName -> TcRnIf gbl lcl Name
newSysName (FastString -> OccName
mkTyVarOccFS (String -> FastString
fsLit String
"ev"))
let tv :: TyVar
tv = Name -> Type -> TyVar
mkTyVar Name
name (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
bndr_ki)
(TyConBinder, [(Name, TyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)])
forall (m :: * -> *) a. Monad m => a -> m a
return (AnonArgFlag -> TyVar -> TyConBinder
mkAnonTyConBinder AnonArgFlag
InvisArg TyVar
tv, [])
ZippedBinder (Anon AnonArgFlag
VisArg Scaled Type
bndr_ki) (Just LHsTyVarBndr () GhcRn
b) ->
(TyConBinder, [(Name, TyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)])
forall (m :: * -> *) a. Monad m => a -> m a
return ((TyConBinder, [(Name, TyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)]))
-> (TyConBinder, [(Name, TyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)])
forall a b. (a -> b) -> a -> b
$
let v_name :: Name
v_name = GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> Name
forall a. NamedThing a => a -> Name
getName GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
LHsTyVarBndr () GhcRn
b
tv :: TyVar
tv = Name -> Type -> TyVar
mkTyVar Name
v_name (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
bndr_ki)
tcb :: TyConBinder
tcb = AnonArgFlag -> TyVar -> TyConBinder
mkAnonTyConBinder AnonArgFlag
VisArg TyVar
tv
in (TyConBinder
tcb, [(Name
v_name, TyVar
tv)])
ZippedBinder (Named (Bndr TyVar
v ArgFlag
Required)) (Just LHsTyVarBndr () GhcRn
b) ->
(TyConBinder, [(Name, TyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)])
forall (m :: * -> *) a. Monad m => a -> m a
return ((TyConBinder, [(Name, TyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)]))
-> (TyConBinder, [(Name, TyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)])
forall a b. (a -> b) -> a -> b
$
let v_name :: Name
v_name = GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> Name
forall a. NamedThing a => a -> Name
getName GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
LHsTyVarBndr () GhcRn
b
tcb :: TyConBinder
tcb = ArgFlag -> TyVar -> TyConBinder
mkNamedTyConBinder ArgFlag
Required TyVar
v
in (TyConBinder
tcb, [(Name
v_name, TyVar
v)])
ZippedBinder
_ -> String
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)])
forall a. String -> a
panic String
"goVis: invalid ZippedBinder"
invis_to_tcb :: TyCoBinder -> TcM TyConBinder
invis_to_tcb :: TyBinder -> IOEnv (Env TcGblEnv TcLclEnv) TyConBinder
invis_to_tcb TyBinder
tb = do
(TyConBinder
tcb, [(Name, TyVar)]
stv) <- ZippedBinder
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TyVar)])
zipped_to_tcb (TyBinder -> Maybe (LHsTyVarBndr () GhcRn) -> ZippedBinder
ZippedBinder TyBinder
tb Maybe (LHsTyVarBndr () GhcRn)
forall a. Maybe a
Nothing)
MASSERT(null stv)
TyConBinder -> IOEnv (Env TcGblEnv TcLclEnv) TyConBinder
forall (m :: * -> *) a. Monad m => a -> m a
return TyConBinder
tcb
check_zipped_binder :: ZippedBinder -> TcM ()
check_zipped_binder :: ZippedBinder -> TcM ()
check_zipped_binder (ZippedBinder TyBinder
_ Maybe (LHsTyVarBndr () GhcRn)
Nothing) = () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
check_zipped_binder (ZippedBinder TyBinder
tb (Just LHsTyVarBndr () GhcRn
b)) =
case GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
-> HsTyVarBndr () GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
LHsTyVarBndr () GhcRn
b of
UserTyVar XUserTyVar GhcRn
_ ()
_ LIdP GhcRn
_ -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
KindedTyVar XKindedTyVar GhcRn
_ ()
_ LIdP GhcRn
v LHsType GhcRn
v_hs_ki -> do
Type
v_ki <- UserTypeCtxt -> LHsType GhcRn -> TcM Type
tcLHsKindSig (Name -> UserTypeCtxt
TyVarBndrKindCtxt (GenLocated SrcSpanAnnN Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnN Name
LIdP GhcRn
v)) LHsType GhcRn
v_hs_ki
TcM Coercion -> TcM ()
forall a. TcM a -> TcM ()
discardResult (TcM Coercion -> TcM ()) -> TcM Coercion -> TcM ()
forall a b. (a -> b) -> a -> b
$
Maybe SDoc -> Type -> Type -> TcM Coercion
unifyKind (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (GenLocated SrcSpanAnnN Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnN Name
LIdP GhcRn
v))
(TyBinder -> Type
tyBinderType TyBinder
tb)
Type
v_ki
split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind)
split_invis :: Type -> Maybe Type -> ([TyBinder], Type)
split_invis Type
sig_ki Maybe Type
Nothing =
Type -> ([TyBinder], Type)
splitInvisPiTys Type
sig_ki
split_invis Type
sig_ki (Just Type
res_ki) =
let n_res_invis_bndrs :: Arity
n_res_invis_bndrs = Type -> Arity
invisibleTyBndrCount Type
res_ki
n_sig_invis_bndrs :: Arity
n_sig_invis_bndrs = Type -> Arity
invisibleTyBndrCount Type
sig_ki
n_inst :: Arity
n_inst = Arity
n_sig_invis_bndrs Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
n_res_invis_bndrs
in Arity -> Type -> ([TyBinder], Type)
splitInvisPiTysN Arity
n_inst Type
sig_ki
data ZippedBinder = ZippedBinder TyBinder (Maybe (LHsTyVarBndr () GhcRn))
zipBinders
:: Kind
-> [LHsTyVarBndr () GhcRn]
-> ( [ZippedBinder]
, [LHsTyVarBndr () GhcRn]
, Kind )
zipBinders :: Type
-> [LHsTyVarBndr () GhcRn]
-> ([ZippedBinder], [LHsTyVarBndr () GhcRn], Type)
zipBinders = [ZippedBinder]
-> TCvSubst
-> Type
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> ([ZippedBinder],
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)], Type)
zip_binders [] TCvSubst
emptyTCvSubst
where
zip_binders :: [ZippedBinder]
-> TCvSubst
-> Type
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> ([ZippedBinder],
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)], Type)
zip_binders [ZippedBinder]
acc TCvSubst
subst Type
ki [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
bs
| (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
b:[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
bs') <- [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
bs
, Just (TyBinder
tb,Type
ki') <- Type -> Maybe (TyBinder, Type)
tcSplitPiTy_maybe Type
ki
, let (TCvSubst
subst', TyBinder
tb') = TCvSubst -> TyBinder -> (TCvSubst, TyBinder)
substTyCoBndr TCvSubst
subst TyBinder
tb
= if TyBinder -> Bool
isInvisibleBinder TyBinder
tb
then [ZippedBinder]
-> TCvSubst
-> Type
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> ([ZippedBinder],
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)], Type)
zip_binders (TyBinder -> Maybe (LHsTyVarBndr () GhcRn) -> ZippedBinder
ZippedBinder TyBinder
tb' Maybe (LHsTyVarBndr () GhcRn)
forall a. Maybe a
Nothing ZippedBinder -> [ZippedBinder] -> [ZippedBinder]
forall a. a -> [a] -> [a]
: [ZippedBinder]
acc) TCvSubst
subst' Type
ki' [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
bs
else [ZippedBinder]
-> TCvSubst
-> Type
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
-> ([ZippedBinder],
[GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)], Type)
zip_binders (TyBinder -> Maybe (LHsTyVarBndr () GhcRn) -> ZippedBinder
ZippedBinder TyBinder
tb' (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
-> Maybe (GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn))
forall a. a -> Maybe a
Just GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)
b) ZippedBinder -> [ZippedBinder] -> [ZippedBinder]
forall a. a -> [a] -> [a]
: [ZippedBinder]
acc) TCvSubst
subst' Type
ki' [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
bs'
| Bool
otherwise
= ([ZippedBinder] -> [ZippedBinder]
forall a. [a] -> [a]
reverse [ZippedBinder]
acc, [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
bs, HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
ki)
tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> SDoc
tooManyBindersErr :: Type -> [LHsTyVarBndr () GhcRn] -> SDoc
tooManyBindersErr Type
ki [LHsTyVarBndr () GhcRn]
bndrs =
SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"Not a function kind:")
Arity
4 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ki) SDoc -> SDoc -> SDoc
$$
SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"but extra binders found:")
Arity
4 ([SDoc] -> SDoc
fsep ((GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> SDoc)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcRn)]
[LHsTyVarBndr () GhcRn]
bndrs))
data ContextKind = TheKind Kind
| AnyKind
| OpenKind
newExpectedKind :: ContextKind -> TcM Kind
newExpectedKind :: ContextKind -> TcM Type
newExpectedKind (TheKind Type
k) = Type -> TcM Type
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
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 { ([VarBndr TyVar ()]
req_tv_bndrs, a
thing) <- SkolemMode
-> [LHsTyVarBndr () GhcRn] -> TcM a -> TcM ([VarBndr TyVar ()], a)
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
; ([TcTyVarBinder], a) -> TcM ([TcTyVarBinder], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([VarBndr TyVar ()] -> [TcTyVarBinder]
forall a. [VarBndr a ()] -> [VarBndr a ArgFlag]
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 { ([InvisTVBinder]
inv_tv_bndrs, a
thing) <- SkolemMode
-> [LHsTyVarBndr Specificity GhcRn]
-> TcM a
-> TcM ([InvisTVBinder], a)
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
; ([TcTyVarBinder], a) -> TcM ([TcTyVarBinder], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([InvisTVBinder] -> [TcTyVarBinder]
forall a. [VarBndr a Specificity] -> [VarBndr a ArgFlag]
tyVarSpecToBinders [InvisTVBinder]
inv_tv_bndrs, a
thing) }
where
skol_mode :: SkolemMode
skol_mode = SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_holes :: HoleInfo
sm_holes = TcTyMode -> HoleInfo
mode_holes TcTyMode
mode }
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) <- SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
forall a. SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrsX SkolemMode
skol_mode HsQTvsRn
XHsOuterImplicit GhcRn
imp_tvs TcM a
thing_inside
; (HsOuterTyVarBndrs flag GhcTc, a)
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsOuterImplicit{hso_ximplicit :: XHsOuterImplicit GhcTc
hso_ximplicit = [TyVar]
XHsOuterImplicit GhcTc
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) <- SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
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)]
[LHsTyVarBndr flag GhcRn]
exp_bndrs TcM a
thing_inside
; (HsOuterTyVarBndrs flag GhcTc, a)
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsOuterExplicit { hso_xexplicit :: XHsOuterExplicit GhcTc flag
hso_xexplicit = [VarBndr TyVar flag]
XHsOuterExplicit GhcTc flag
exp_tvs'
, hso_bndrs :: [LHsTyVarBndr flag (NoGhcTc GhcTc)]
hso_bndrs = [LHsTyVarBndr flag (NoGhcTc GhcRn)]
[LHsTyVarBndr flag (NoGhcTc GhcTc)]
exp_bndrs }
, a
thing) }
getOuterTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar]
getOuterTyVars :: forall flag. HsOuterTyVarBndrs flag GhcTc -> [TyVar]
getOuterTyVars (HsOuterImplicit { hso_ximplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass
hso_ximplicit = XHsOuterImplicit GhcTc
tvs }) = [TyVar]
XHsOuterImplicit GhcTc
tvs
getOuterTyVars (HsOuterExplicit { hso_xexplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterExplicit pass flag
hso_xexplicit = XHsOuterExplicit GhcTc flag
tvbs }) = [VarBndr TyVar flag] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TyVar flag]
XHsOuterExplicit GhcTc flag
tvbs
scopedSortOuter :: HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder]
scopedSortOuter :: HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder]
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 [TyVar]
XHsOuterImplicit GhcTc
imp_tvs
; [InvisTVBinder] -> TcM [InvisTVBinder]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyVar -> Specificity -> InvisTVBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv Specificity
SpecifiedSpec | TyVar
tv <- [TyVar]
imp_tvs] }
scopedSortOuter (HsOuterExplicit{hso_xexplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterExplicit pass flag
hso_xexplicit = XHsOuterExplicit GhcTc Specificity
exp_tvs})
=
[InvisTVBinder] -> TcM [InvisTVBinder]
forall (m :: * -> *) a. Monad m => a -> m a
return [InvisTVBinder]
XHsOuterExplicit GhcTc Specificity
exp_tvs
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
= SkolemMode
-> HsOuterSigTyVarBndrs GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, a)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
bindOuterTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
True, sm_tvtv :: Bool
sm_tvtv = Bool
True })
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
= SkolemMode
-> HsOuterSigTyVarBndrs GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, a)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
bindOuterTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
True, sm_tvtv :: Bool
sm_tvtv = Bool
True
, sm_holes :: HoleInfo
sm_holes = TcTyMode -> HoleInfo
mode_holes TcTyMode
mode })
bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn
-> TcM a
-> TcM ([TcTyVar], a)
bindOuterFamEqnTKBndrs_Q_Tv :: forall a.
HsOuterFamEqnTyVarBndrs GhcRn -> TcM a -> TcM ([TyVar], a)
bindOuterFamEqnTKBndrs_Q_Tv HsOuterFamEqnTyVarBndrs GhcRn
hs_bndrs TcM a
thing_inside
= (HsOuterTyVarBndrs () GhcTc -> [TyVar])
-> IOEnv (Env TcGblEnv TcLclEnv) (HsOuterTyVarBndrs () GhcTc, a)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], a)
forall (m :: * -> *) a b r.
Monad m =>
(a -> b) -> m (a, r) -> m (b, r)
liftFstM HsOuterTyVarBndrs () GhcTc -> [TyVar]
forall flag. HsOuterTyVarBndrs flag GhcTc -> [TyVar]
getOuterTyVars (IOEnv (Env TcGblEnv TcLclEnv) (HsOuterTyVarBndrs () GhcTc, a)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], a))
-> IOEnv (Env TcGblEnv TcLclEnv) (HsOuterTyVarBndrs () GhcTc, a)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], a)
forall a b. (a -> b) -> a -> b
$
SkolemMode
-> HsOuterFamEqnTyVarBndrs GhcRn
-> TcM a
-> IOEnv (Env TcGblEnv TcLclEnv) (HsOuterTyVarBndrs () GhcTc, a)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
bindOuterTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_parent :: Bool
sm_parent = Bool
True
, sm_tvtv :: Bool
sm_tvtv = Bool
True })
HsOuterFamEqnTyVarBndrs GhcRn
hs_bndrs TcM a
thing_inside
bindOuterFamEqnTKBndrs :: HsOuterFamEqnTyVarBndrs GhcRn
-> TcM a
-> TcM ([TcTyVar], a)
bindOuterFamEqnTKBndrs :: forall a.
HsOuterFamEqnTyVarBndrs GhcRn -> TcM a -> TcM ([TyVar], a)
bindOuterFamEqnTKBndrs HsOuterFamEqnTyVarBndrs GhcRn
hs_bndrs TcM a
thing_inside
= (HsOuterTyVarBndrs () GhcTc -> [TyVar])
-> IOEnv (Env TcGblEnv TcLclEnv) (HsOuterTyVarBndrs () GhcTc, a)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], a)
forall (m :: * -> *) a b r.
Monad m =>
(a -> b) -> m (a, r) -> m (b, r)
liftFstM HsOuterTyVarBndrs () GhcTc -> [TyVar]
forall flag. HsOuterTyVarBndrs flag GhcTc -> [TyVar]
getOuterTyVars (IOEnv (Env TcGblEnv TcLclEnv) (HsOuterTyVarBndrs () GhcTc, a)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], a))
-> IOEnv (Env TcGblEnv TcLclEnv) (HsOuterTyVarBndrs () GhcTc, a)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], a)
forall a b. (a -> b) -> a -> b
$
SkolemMode
-> HsOuterFamEqnTyVarBndrs GhcRn
-> TcM a
-> IOEnv (Env TcGblEnv TcLclEnv) (HsOuterTyVarBndrs () GhcTc, a)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
bindOuterTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_parent :: Bool
sm_parent = Bool
True })
HsOuterFamEqnTyVarBndrs GhcRn
hs_bndrs TcM a
thing_inside
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 = SkolemMode
-> SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> SkolemInfo
-> HsOuterTyVarBndrs flag GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
tcOuterTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False })
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) <- SkolemMode -> SkolemInfo -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
forall a.
SkolemMode -> SkolemInfo -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
tcImplicitTKBndrsX SkolemMode
skol_mode SkolemInfo
skol_info HsQTvsRn
XHsOuterImplicit GhcRn
imp_tvs TcM a
thing_inside
; (HsOuterTyVarBndrs flag GhcTc, a)
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsOuterImplicit{hso_ximplicit :: XHsOuterImplicit GhcTc
hso_ximplicit = [TyVar]
XHsOuterImplicit GhcTc
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) <- SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
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)]
[LHsTyVarBndr flag GhcRn]
exp_bndrs TcM a
thing_inside
; (HsOuterTyVarBndrs flag GhcTc, a)
-> TcM (HsOuterTyVarBndrs flag GhcTc, a)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsOuterExplicit { hso_xexplicit :: XHsOuterExplicit GhcTc flag
hso_xexplicit = [VarBndr TyVar flag]
XHsOuterExplicit GhcTc flag
exp_tvs'
, hso_bndrs :: [LHsTyVarBndr flag (NoGhcTc GhcTc)]
hso_bndrs = [LHsTyVarBndr flag (NoGhcTc GhcRn)]
[LHsTyVarBndr flag (NoGhcTc GhcTc)]
exp_bndrs }
, a
thing) }
tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed
=> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrs :: forall flag a.
OutputableBndrFlag flag 'Renamed =>
[LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrs = SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
tcExplicitTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
True })
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
= do { (TcLevel
tclvl, WantedConstraints
wanted, ([VarBndr TyVar flag]
skol_tvs, a
res))
<- TcM ([VarBndr TyVar flag], a)
-> TcM (TcLevel, WantedConstraints, ([VarBndr TyVar flag], a))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (TcM ([VarBndr TyVar flag], a)
-> TcM (TcLevel, WantedConstraints, ([VarBndr TyVar flag], a)))
-> TcM ([VarBndr TyVar flag], a)
-> TcM (TcLevel, WantedConstraints, ([VarBndr TyVar flag], a))
forall a b. (a -> b) -> a -> b
$
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
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 (TcM a -> TcM ([VarBndr TyVar flag], a))
-> TcM a -> TcM ([VarBndr TyVar flag], a)
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
; let skol_info :: SkolemInfo
skol_info = SDoc -> SkolemInfo
ForAllSkol ([SDoc] -> SDoc
fsep ((GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn) -> SDoc)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
[LHsTyVarBndr flag GhcRn]
bndrs))
; SkolemInfo -> [TyVar] -> TcLevel -> WantedConstraints -> TcM ()
emitResidualTvConstraint SkolemInfo
skol_info ([VarBndr TyVar flag] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [VarBndr TyVar flag]
skol_tvs) TcLevel
tclvl WantedConstraints
wanted
; ([VarBndr TyVar flag], a) -> TcM ([VarBndr TyVar flag], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([VarBndr TyVar flag]
skol_tvs, a
res) }
bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv
:: (OutputableBndrFlag flag 'Renamed)
=> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrs_Skol :: forall flag a.
OutputableBndrFlag flag 'Renamed =>
[LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrs_Skol = SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False })
bindExplicitTKBndrs_Tv :: forall flag a.
OutputableBndrFlag flag 'Renamed =>
[LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrs_Tv = SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
True, sm_tvtv :: Bool
sm_tvtv = Bool
True })
bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv
:: ContextKind
-> [LHsTyVarBndr () GhcRn]
-> TcM a
-> TcM ([TcTyVar], a)
bindExplicitTKBndrs_Q_Skol :: forall a.
ContextKind -> [LHsTyVarBndr () GhcRn] -> TcM a -> TcM ([TyVar], a)
bindExplicitTKBndrs_Q_Skol ContextKind
ctxt_kind [LHsTyVarBndr () GhcRn]
hs_bndrs TcM a
thing_inside
= ([VarBndr TyVar ()] -> [TyVar])
-> IOEnv (Env TcGblEnv TcLclEnv) ([VarBndr TyVar ()], a)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], a)
forall (m :: * -> *) a b r.
Monad m =>
(a -> b) -> m (a, r) -> m (b, r)
liftFstM [VarBndr TyVar ()] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars (IOEnv (Env TcGblEnv TcLclEnv) ([VarBndr TyVar ()], a)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], a))
-> IOEnv (Env TcGblEnv TcLclEnv) ([VarBndr TyVar ()], a)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], a)
forall a b. (a -> b) -> a -> b
$
SkolemMode
-> [LHsTyVarBndr () GhcRn]
-> TcM a
-> IOEnv (Env TcGblEnv TcLclEnv) ([VarBndr TyVar ()], a)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_parent :: Bool
sm_parent = Bool
True
, sm_kind :: ContextKind
sm_kind = ContextKind
ctxt_kind })
[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
= ([VarBndr TyVar ()] -> [TyVar])
-> IOEnv (Env TcGblEnv TcLclEnv) ([VarBndr TyVar ()], a)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], a)
forall (m :: * -> *) a b r.
Monad m =>
(a -> b) -> m (a, r) -> m (b, r)
liftFstM [VarBndr TyVar ()] -> [TyVar]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars (IOEnv (Env TcGblEnv TcLclEnv) ([VarBndr TyVar ()], a)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], a))
-> IOEnv (Env TcGblEnv TcLclEnv) ([VarBndr TyVar ()], a)
-> IOEnv (Env TcGblEnv TcLclEnv) ([TyVar], a)
forall a b. (a -> b) -> a -> b
$
SkolemMode
-> [LHsTyVarBndr () GhcRn]
-> TcM a
-> IOEnv (Env TcGblEnv TcLclEnv) ([VarBndr TyVar ()], a)
forall flag a.
OutputableBndrFlag flag 'Renamed =>
SkolemMode
-> [LHsTyVarBndr flag GhcRn]
-> TcM a
-> TcM ([VarBndr TyVar flag], a)
bindExplicitTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_parent :: Bool
sm_parent = Bool
True
, sm_tvtv :: Bool
sm_tvtv = Bool
True, 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" ([GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
[LHsTyVarBndr flag GhcRn]
hs_tvs)
; [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
-> TcM ([VarBndr TyVar flag], a)
go [GenLocated SrcSpanAnnA (HsTyVarBndr flag GhcRn)]
[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
; ([VarBndr TyVar flag], a) -> TcM ([VarBndr TyVar flag], a)
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 { NameEnv TcTyThing
lcl_env <- TcM (NameEnv TcTyThing)
getLclTypeEnv
; TyVar
tv <- NameEnv TcTyThing
-> HsTyVarBndr flag GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
tc_hs_bndr NameEnv TcTyThing
lcl_env HsTyVarBndr flag GhcRn
hs_tv
; ([VarBndr TyVar flag]
tvs,a
res) <- [(Name, TyVar)]
-> TcM ([VarBndr TyVar flag], a) -> TcM ([VarBndr TyVar flag], a)
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(HsTyVarBndr flag GhcRn -> IdP GhcRn
forall flag (p :: Pass).
HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsTyVarName HsTyVarBndr flag GhcRn
hs_tv, TyVar
tv)] (TcM ([VarBndr TyVar flag], a) -> TcM ([VarBndr TyVar flag], a))
-> TcM ([VarBndr TyVar flag], a) -> TcM ([VarBndr TyVar flag], a)
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
; ([VarBndr TyVar flag], a) -> TcM ([VarBndr TyVar flag], a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> flag -> VarBndr TyVar flag
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv (HsTyVarBndr flag GhcRn -> flag
forall flag (pass :: Pass). HsTyVarBndr flag (GhcPass pass) -> flag
hsTyVarBndrFlag HsTyVarBndr flag GhcRn
hs_tv)VarBndr TyVar flag -> [VarBndr TyVar flag] -> [VarBndr TyVar flag]
forall a. a -> [a] -> [a]
:[VarBndr TyVar flag]
tvs, a
res) }
tc_hs_bndr :: NameEnv TcTyThing
-> HsTyVarBndr flag GhcRn -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
tc_hs_bndr NameEnv TcTyThing
lcl_env (UserTyVar XUserTyVar GhcRn
_ flag
_ (L Anno (IdGhcP 'Renamed)
_ Name
name))
| Bool
check_parent
, Just (ATyVar Name
_ TyVar
tv) <- NameEnv TcTyThing -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TcTyThing
lcl_env Name
name
= TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
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 -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
newTyVarBndr SkolemMode
skol_mode Name
name Type
kind }
tc_hs_bndr NameEnv TcTyThing
lcl_env (KindedTyVar XKindedTyVar GhcRn
_ flag
_ (L Anno (IdGhcP 'Renamed)
_ Name
name) LHsType GhcRn
lhs_kind)
| Bool
check_parent
, Just (ATyVar Name
_ TyVar
tv) <- NameEnv TcTyThing -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TcTyThing
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
; TcM Coercion -> TcM ()
forall a. TcM a -> TcM ()
discardResult (TcM Coercion -> TcM ()) -> TcM Coercion -> TcM ()
forall a b. (a -> b) -> a -> b
$
Maybe SDoc -> Type -> Type -> TcM Coercion
unifyKind (SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)) Type
kind (TyVar -> Type
tyVarKind TyVar
tv)
; TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
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 -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
newTyVarBndr SkolemMode
skol_mode Name
name Type
kind }
newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar
newTyVarBndr :: SkolemMode -> Name -> Type -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
newTyVarBndr (SM { sm_clone :: SkolemMode -> Bool
sm_clone = Bool
clone, sm_tvtv :: SkolemMode -> Bool
sm_tvtv = Bool
tvtv }) Name
name Type
kind
= do { Name
name <- case Bool
clone of
Bool
True -> do { Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; Name -> TcM Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Unique -> Name
setNameUnique Name
name Unique
uniq) }
Bool
False -> Name -> TcM Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
; TcTyVarDetails
details <- case Bool
tvtv of
Bool
True -> MetaInfo -> TcM TcTyVarDetails
newMetaDetails MetaInfo
TyVarTv
Bool
False -> do { TcLevel
lvl <- TcM TcLevel
getTcLevel
; TcTyVarDetails -> TcM TcTyVarDetails
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLevel -> Bool -> TcTyVarDetails
SkolemTv TcLevel
lvl Bool
False) }
; TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
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
= do { (TcLevel
tclvl, WantedConstraints
wanted, ([TyVar]
skol_tvs, a
res))
<- TcM ([TyVar], a) -> TcM (TcLevel, WantedConstraints, ([TyVar], a))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (TcM ([TyVar], a)
-> TcM (TcLevel, WantedConstraints, ([TyVar], a)))
-> TcM ([TyVar], a)
-> TcM (TcLevel, WantedConstraints, ([TyVar], a))
forall a b. (a -> b) -> a -> b
$
SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
forall a. SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrsX SkolemMode
skol_mode HsQTvsRn
bndrs (TcM a -> TcM ([TyVar], a)) -> TcM a -> TcM ([TyVar], a)
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
; ([TyVar], a) -> TcM ([TyVar], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
skol_tvs, a
res) }
bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,
bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv
:: [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Skol :: forall a. HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Skol = SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
forall a. SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
True })
bindImplicitTKBndrs_Tv :: forall a. HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Tv = SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
forall a. SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
True, sm_tvtv :: Bool
sm_tvtv = Bool
True })
bindImplicitTKBndrs_Q_Skol :: forall a. HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Skol = SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
forall a. SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_parent :: Bool
sm_parent = Bool
True })
bindImplicitTKBndrs_Q_Tv :: forall a. HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrs_Q_Tv = SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
forall a. SkolemMode -> HsQTvsRn -> TcM a -> TcM ([TyVar], a)
bindImplicitTKBndrsX (SkolemMode
smVanilla { sm_clone :: Bool
sm_clone = Bool
False, sm_parent :: Bool
sm_parent = Bool
True, sm_tvtv :: Bool
sm_tvtv = Bool
True })
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 { NameEnv TcTyThing
lcl_env <- TcM (NameEnv TcTyThing)
getLclTypeEnv
; [TyVar]
tkvs <- (Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> HsQTvsRn -> TcM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NameEnv TcTyThing -> Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
new_tv NameEnv TcTyThing
lcl_env) HsQTvsRn
tv_names
; String -> SDoc -> TcM ()
traceTc String
"bindImplicitTKBndrsX" (HsQTvsRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsQTvsRn
tv_names SDoc -> SDoc -> SDoc
$$ [TyVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVar]
tkvs)
; a
res <- [(Name, TyVar)] -> TcM a -> TcM a
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv (HsQTvsRn
tv_names HsQTvsRn -> [TyVar] -> [(Name, TyVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TyVar]
tkvs)
TcM a
thing_inside
; ([TyVar], a) -> TcM ([TyVar], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
tkvs, a
res) }
where
new_tv :: NameEnv TcTyThing -> Name -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
new_tv NameEnv TcTyThing
lcl_env Name
name
| Bool
check_parent
, Just (ATyVar Name
_ TyVar
tv) <- NameEnv TcTyThing -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TcTyThing
lcl_env Name
name
= TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
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 -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
newTyVarBndr SkolemMode
skol_mode Name
name Type
kind }
data SkolemMode
= SM { SkolemMode -> Bool
sm_parent :: Bool
, SkolemMode -> Bool
sm_clone :: Bool
, SkolemMode -> Bool
sm_tvtv :: Bool
, SkolemMode -> ContextKind
sm_kind :: ContextKind
, SkolemMode -> HoleInfo
sm_holes :: HoleInfo
}
smVanilla :: SkolemMode
smVanilla :: SkolemMode
smVanilla = SM { sm_clone :: Bool
sm_clone = String -> Bool
forall a. String -> a
panic String
"sm_clone"
, sm_parent :: Bool
sm_parent = Bool
False
, sm_tvtv :: Bool
sm_tvtv = Bool
False
, sm_kind :: ContextKind
sm_kind = ContextKind
AnyKind
, sm_holes :: HoleInfo
sm_holes = HoleInfo
forall a. Maybe a
Nothing }
bindTyClTyVars :: Name
-> (TcTyCon -> [TyConBinder] -> Kind -> TcM a) -> TcM a
bindTyClTyVars :: forall a.
Name -> (TyCon -> [TyConBinder] -> Type -> TcM a) -> TcM a
bindTyClTyVars Name
tycon_name TyCon -> [TyConBinder] -> Type -> TcM a
thing_inside
= do { TyCon
tycon <- HasDebugCallStack => Name -> TcM TyCon
Name -> TcM TyCon
tcLookupTcTyCon Name
tycon_name
; let scoped_prs :: [(Name, TyVar)]
scoped_prs = TyCon -> [(Name, TyVar)]
tcTyConScopedTyVars TyCon
tycon
res_kind :: Type
res_kind = TyCon -> Type
tyConResKind TyCon
tycon
binders :: [TyConBinder]
binders = TyCon -> [TyConBinder]
tyConBinders TyCon
tycon
; String -> SDoc -> TcM ()
traceTc String
"bindTyClTyVars" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tycon_name SDoc -> SDoc -> SDoc
<+> [TyConBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyConBinder]
binders SDoc -> SDoc -> SDoc
$$ [(Name, TyVar)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
scoped_prs)
; [(Name, TyVar)] -> TcM a -> TcM a
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
scoped_prs (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TyCon -> [TyConBinder] -> Type -> TcM a
thing_inside TyCon
tycon [TyConBinder]
binders Type
res_kind }
zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]
zonkAndScopedSort :: [TyVar] -> TcM [TyVar]
zonkAndScopedSort [TyVar]
spec_tkvs
= do { [TyVar]
spec_tkvs <- (TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar)
-> [TyVar] -> TcM [TyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
TyVar -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
zonkTcTyVarToTyVar [TyVar]
spec_tkvs
; [TyVar] -> TcM [TyVar]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar] -> [TyVar]
scopedSort [TyVar]
spec_tkvs) }
kindGeneralizeSome :: WantedConstraints
-> TcType
-> TcM [KindVar]
kindGeneralizeSome :: WantedConstraints -> Type -> TcM [TyVar]
kindGeneralizeSome 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
; CandidatesQTvs -> TcM [TyVar]
quantifyTyVars CandidatesQTvs
dvs }
filterConstrainedCandidates
:: WantedConstraints
-> CandidatesQTvs
-> TcM CandidatesQTvs
filterConstrainedCandidates :: WantedConstraints -> CandidatesQTvs -> TcM CandidatesQTvs
filterConstrainedCandidates WantedConstraints
wanted CandidatesQTvs
dvs
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
wanted
= CandidatesQTvs -> TcM CandidatesQTvs
forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dvs
| Bool
otherwise
= do { VarSet
wc_tvs <- VarSet -> TcM VarSet
zonkTyCoVarsAndFV (WantedConstraints -> VarSet
tyCoVarsOfWC WantedConstraints
wanted)
; let (VarSet
to_promote, CandidatesQTvs
dvs') = CandidatesQTvs -> (TyVar -> Bool) -> (VarSet, CandidatesQTvs)
partitionCandidates CandidatesQTvs
dvs (TyVar -> VarSet -> Bool
`elemVarSet` VarSet
wc_tvs)
; Bool
_ <- VarSet -> TcRnIf TcGblEnv TcLclEnv Bool
promoteTyVarSet VarSet
to_promote
; CandidatesQTvs -> TcM CandidatesQTvs
forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dvs' }
kindGeneralizeAll :: TcType -> TcM [KindVar]
kindGeneralizeAll :: Type -> TcM [TyVar]
kindGeneralizeAll Type
kind_or_type
= do { String -> SDoc -> TcM ()
traceTc String
"kindGeneralizeAll" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kind_or_type)
; CandidatesQTvs
dvs <- Type -> TcM CandidatesQTvs
candidateQTyVarsOfKind Type
kind_or_type
; CandidatesQTvs -> TcM [TyVar]
quantifyTyVars CandidatesQTvs
dvs }
kindGeneralizeNone :: TcType
-> TcM ()
kindGeneralizeNone :: Type -> TcM ()
kindGeneralizeNone Type
kind_or_type
= do { String -> SDoc -> TcM ()
traceTc String
"kindGeneralizeNone" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kind_or_type)
; CandidatesQTvs
dvs <- Type -> TcM CandidatesQTvs
candidateQTyVarsOfKind Type
kind_or_type
; Bool
_ <- VarSet -> TcRnIf TcGblEnv TcLclEnv Bool
promoteTyVarSet (CandidatesQTvs -> VarSet
candidateKindVars CandidatesQTvs
dvs)
; () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
etaExpandAlgTyCon :: [TyConBinder]
-> Kind
-> TcM ([TyConBinder], Kind)
etaExpandAlgTyCon :: [TyConBinder] -> Type -> TcM ([TyConBinder], Type)
etaExpandAlgTyCon [TyConBinder]
tc_bndrs Type
kind
= do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; UniqSupply
uniqs <- TcRnIf TcGblEnv TcLclEnv UniqSupply
forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
; LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
; let new_occs :: [OccName]
new_occs = [ OccName
occ
| String
str <- [String]
allNameStrings
, let occ :: OccName
occ = NameSpace -> String -> OccName
mkOccName NameSpace
tvName String
str
, Maybe Name -> Bool
forall a. Maybe a -> Bool
isNothing (LocalRdrEnv -> OccName -> Maybe Name
lookupLocalRdrOcc LocalRdrEnv
rdr_env OccName
occ)
, Bool -> Bool
not (OccName
occ OccName -> [OccName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OccName]
lhs_occs) ]
new_uniqs :: [Unique]
new_uniqs = UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
uniqs
subst :: TCvSubst
subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet ([TyVar] -> VarSet
mkVarSet [TyVar]
lhs_tvs))
; ([TyConBinder], Type) -> TcM ([TyConBinder], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan
-> [OccName]
-> [Unique]
-> TCvSubst
-> [TyConBinder]
-> Type
-> ([TyConBinder], Type)
go SrcSpan
loc [OccName]
new_occs [Unique]
new_uniqs TCvSubst
subst [] Type
kind) }
where
lhs_tvs :: [TyVar]
lhs_tvs = (TyConBinder -> TyVar) -> [TyConBinder] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> TyVar
forall tv argf. VarBndr tv argf -> tv
binderVar [TyConBinder]
tc_bndrs
lhs_occs :: [OccName]
lhs_occs = (TyVar -> OccName) -> [TyVar] -> [OccName]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> OccName
forall a. NamedThing a => a -> OccName
getOccName [TyVar]
lhs_tvs
go :: SrcSpan
-> [OccName]
-> [Unique]
-> TCvSubst
-> [TyConBinder]
-> Type
-> ([TyConBinder], Type)
go SrcSpan
loc [OccName]
occs [Unique]
uniqs TCvSubst
subst [TyConBinder]
acc Type
kind
= case Type -> Maybe (TyBinder, Type)
splitPiTy_maybe Type
kind of
Maybe (TyBinder, Type)
Nothing -> ([TyConBinder] -> [TyConBinder]
forall a. [a] -> [a]
reverse [TyConBinder]
acc, HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
kind)
Just (Anon AnonArgFlag
af Scaled Type
arg, Type
kind')
-> SrcSpan
-> [OccName]
-> [Unique]
-> TCvSubst
-> [TyConBinder]
-> Type
-> ([TyConBinder], Type)
go SrcSpan
loc [OccName]
occs' [Unique]
uniqs' TCvSubst
subst' (TyConBinder
tcb TyConBinder -> [TyConBinder] -> [TyConBinder]
forall a. a -> [a] -> [a]
: [TyConBinder]
acc) Type
kind'
where
arg' :: Type
arg' = HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
arg)
tv :: TyVar
tv = Name -> Type -> TyVar
mkTyVar (Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
loc) Type
arg'
subst' :: TCvSubst
subst' = TCvSubst -> TyVar -> TCvSubst
extendTCvInScope TCvSubst
subst TyVar
tv
tcb :: TyConBinder
tcb = TyVar -> TyConBndrVis -> TyConBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv (AnonArgFlag -> TyConBndrVis
AnonTCB AnonArgFlag
af)
(Unique
uniq:[Unique]
uniqs') = [Unique]
uniqs
(OccName
occ:[OccName]
occs') = [OccName]
occs
Just (Named (Bndr TyVar
tv ArgFlag
vis), Type
kind')
-> SrcSpan
-> [OccName]
-> [Unique]
-> TCvSubst
-> [TyConBinder]
-> Type
-> ([TyConBinder], Type)
go SrcSpan
loc [OccName]
occs [Unique]
uniqs TCvSubst
subst' (TyConBinder
tcb TyConBinder -> [TyConBinder] -> [TyConBinder]
forall a. a -> [a] -> [a]
: [TyConBinder]
acc) Type
kind'
where
(TCvSubst
subst', TyVar
tv') = HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar)
TCvSubst -> TyVar -> (TCvSubst, TyVar)
substTyVarBndr TCvSubst
subst TyVar
tv
tcb :: TyConBinder
tcb = TyVar -> TyConBndrVis -> TyConBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv' (ArgFlag -> TyConBndrVis
NamedTCB ArgFlag
vis)
data DataSort
= DataDeclSort NewOrData
| DataInstanceSort NewOrData
| DataFamilySort
data AllowedDataResKind
= AnyTYPEKind
| AnyBoxedKind
| LiftedKind
isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool
isAllowedDataResKind :: AllowedDataResKind -> Type -> Bool
isAllowedDataResKind AllowedDataResKind
AnyTYPEKind Type
kind = Type -> Bool
tcIsRuntimeTypeKind 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 <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; String -> SDoc -> TcM ()
traceTc String
"checkDataKindSig" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kind)
; Bool -> SDoc -> TcM ()
checkTc (DynFlags -> Bool
tYPE_ok DynFlags
dflags Bool -> Bool -> Bool
|| Bool
is_kind_var)
(DynFlags -> SDoc
err_msg DynFlags
dflags) }
where
res_kind :: Type
res_kind = ([TyBinder], Type) -> Type
forall a b. (a, b) -> b
snd (Type -> ([TyBinder], Type)
tcSplitPiTys Type
kind)
pp_dec :: SDoc
pp_dec :: SDoc
pp_dec = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$
case DataSort
data_sort of
DataDeclSort NewOrData
DataType -> String
"Data type"
DataDeclSort NewOrData
NewType -> String
"Newtype"
DataInstanceSort NewOrData
DataType -> String
"Data instance"
DataInstanceSort NewOrData
NewType -> String
"Newtype instance"
DataSort
DataFamilySort -> String
"Data family"
is_newtype :: Bool
is_newtype :: Bool
is_newtype =
case DataSort
data_sort of
DataDeclSort NewOrData
new_or_data -> NewOrData
new_or_data NewOrData -> NewOrData -> Bool
forall a. Eq a => a -> a -> Bool
== NewOrData
NewType
DataInstanceSort NewOrData
new_or_data -> NewOrData
new_or_data NewOrData -> NewOrData -> Bool
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 = Maybe (TyVar, Coercion) -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Maybe (TyVar, Coercion)
tcGetCastedTyVar_maybe Type
res_kind)
| Bool
otherwise = Bool
False
pp_allowed_kind :: DynFlags -> SDoc
pp_allowed_kind DynFlags
dflags =
case DynFlags -> AllowedDataResKind
allowed_kind DynFlags
dflags of
AllowedDataResKind
AnyTYPEKind -> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tYPETyCon
AllowedDataResKind
AnyBoxedKind -> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
boxedRepDataConTyCon
AllowedDataResKind
LiftedKind -> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
liftedTypeKind
err_msg :: DynFlags -> SDoc
err_msg :: DynFlags -> SDoc
err_msg DynFlags
dflags =
[SDoc] -> SDoc
sep [ [SDoc] -> SDoc
sep [ SDoc
pp_dec SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"has non-" SDoc -> SDoc -> SDoc
<>
DynFlags -> SDoc
pp_allowed_kind DynFlags
dflags
, (if Bool
is_data_family then String -> SDoc
text String
"and non-variable" else SDoc
empty) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"return kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kind) ]
, DynFlags -> SDoc
ext_hint DynFlags
dflags ]
ext_hint :: DynFlags -> SDoc
ext_hint DynFlags
dflags
| Type -> Bool
tcIsRuntimeTypeKind Type
kind
, Bool
is_newtype
, Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnliftedNewtypes DynFlags
dflags)
= String -> SDoc
text String
"Perhaps you intended to use UnliftedNewtypes"
| Type -> Bool
tcIsBoxedTypeKind Type
kind
, Bool
is_datatype
, Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.UnliftedDatatypes DynFlags
dflags)
= String -> SDoc
text String
"Perhaps you intended to use UnliftedDatatypes"
| Bool
otherwise
= SDoc
empty
checkClassKindSig :: Kind -> TcM ()
checkClassKindSig :: Type -> TcM ()
checkClassKindSig Type
kind = Bool -> SDoc -> TcM ()
checkTc (Type -> Bool
tcIsConstraintKind Type
kind) SDoc
err_msg
where
err_msg :: SDoc
err_msg :: SDoc
err_msg =
String -> SDoc
text String
"Kind signature on a class must end with" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
constraintKind SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"unobscured by type families"
tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]
tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]
tcbVisibilities TyCon
tc [Type]
orig_args
= Type -> TCvSubst -> [Type] -> [TyConBndrVis]
go (TyCon -> Type
tyConKind TyCon
tc) TCvSubst
init_subst [Type]
orig_args
where
init_subst :: TCvSubst
init_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet ([Type] -> VarSet
tyCoVarsOfTypes [Type]
orig_args))
go :: Type -> TCvSubst -> [Type] -> [TyConBndrVis]
go Type
_ TCvSubst
_ []
= []
go Type
fun_kind TCvSubst
subst all_args :: [Type]
all_args@(Type
arg : [Type]
args)
| Just (TyBinder
tcb, Type
inner_kind) <- Type -> Maybe (TyBinder, Type)
splitPiTy_maybe Type
fun_kind
= case TyBinder
tcb of
Anon AnonArgFlag
af Scaled Type
_ -> AnonArgFlag -> TyConBndrVis
AnonTCB AnonArgFlag
af TyConBndrVis -> [TyConBndrVis] -> [TyConBndrVis]
forall a. a -> [a] -> [a]
: Type -> TCvSubst -> [Type] -> [TyConBndrVis]
go Type
inner_kind TCvSubst
subst [Type]
args
Named (Bndr TyVar
tv ArgFlag
vis) -> ArgFlag -> TyConBndrVis
NamedTCB ArgFlag
vis TyConBndrVis -> [TyConBndrVis] -> [TyConBndrVis]
forall a. a -> [a] -> [a]
: Type -> TCvSubst -> [Type] -> [TyConBndrVis]
go Type
inner_kind TCvSubst
subst' [Type]
args
where
subst' :: TCvSubst
subst' = TCvSubst -> TyVar -> Type -> TCvSubst
extendTCvSubst TCvSubst
subst TyVar
tv Type
arg
| Bool -> Bool
not (TCvSubst -> Bool
isEmptyTCvSubst TCvSubst
subst)
= Type -> TCvSubst -> [Type] -> [TyConBndrVis]
go (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
fun_kind) TCvSubst
init_subst [Type]
all_args
| Bool
otherwise
= String -> SDoc -> [TyConBndrVis]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"addTcbVisibilities" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
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, InvisTVBinder)], [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) <- LHsType GhcRn -> (Maybe (LHsContext GhcRn), LHsType GhcRn)
forall (pass :: Pass).
LHsType (GhcPass pass)
-> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))
splitLHsQualTy LHsType GhcRn
body_ty
= UserTypeCtxt
-> GenLocated SrcSpanAnnA (HsSigType GhcRn)
-> TcM
([(Name, TyVar)], Maybe Type, [(Name, InvisTVBinder)], [Type],
Type)
-> TcM
([(Name, TyVar)], Maybe Type, [(Name, InvisTVBinder)], [Type],
Type)
forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt GenLocated SrcSpanAnnA (HsSigType GhcRn)
LHsSigType GhcRn
sig_ty (TcM
([(Name, TyVar)], Maybe Type, [(Name, InvisTVBinder)], [Type],
Type)
-> TcM
([(Name, TyVar)], Maybe Type, [(Name, InvisTVBinder)], [Type],
Type))
-> TcM
([(Name, TyVar)], Maybe Type, [(Name, InvisTVBinder)], [Type],
Type)
-> TcM
([(Name, TyVar)], Maybe Type, [(Name, InvisTVBinder)], [Type],
Type)
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))
<- String
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type))
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type))
forall a. String -> TcM a -> TcM a
solveEqualities String
"tcHsPartialSigType" (TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type))
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type)))
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type))
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type))
forall a b. (a -> b) -> a -> b
$
HsQTvsRn
-> ([(Name, TyVar)]
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type)))
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type))
forall a. HsQTvsRn -> ([(Name, TyVar)] -> TcM a) -> TcM a
bindNamedWildCardBinders HsQTvsRn
XHsWC GhcRn (LHsSigType GhcRn)
sig_wcs (([(Name, TyVar)]
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type)))
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type)))
-> ([(Name, TyVar)]
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type)))
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type))
forall a b. (a -> b) -> a -> b
$ \ [(Name, TyVar)]
wcs ->
TcTyMode
-> HsOuterSigTyVarBndrs GhcRn
-> TcM ([(Name, TyVar)], Maybe Type, [Type], Type)
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type))
forall a.
TcTyMode
-> HsOuterSigTyVarBndrs GhcRn
-> TcM a
-> TcM (HsOuterTyVarBndrs Specificity GhcTc, a)
bindOuterSigTKBndrs_Tv_M TcTyMode
mode HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs (TcM ([(Name, TyVar)], Maybe Type, [Type], Type)
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type)))
-> TcM ([(Name, TyVar)], Maybe Type, [Type], Type)
-> TcM
(HsOuterTyVarBndrs Specificity GhcTc,
([(Name, TyVar)], Maybe Type, [Type], Type))
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 <- LHsType GhcRn -> TcM Type -> TcM Type
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_tau (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
hs_tau Type
ek
; ([(Name, TyVar)], Maybe Type, [Type], Type)
-> TcM ([(Name, TyVar)], Maybe Type, [Type], Type)
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" SDoc
empty
; [InvisTVBinder]
outer_tv_bndrs <- HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder]
scopedSortOuter HsOuterTyVarBndrs Specificity GhcTc
outer_bndrs
; String -> SDoc -> TcM ()
traceTc String
"tcHsPartialSigType 3" SDoc
empty
; Type -> TcM ()
kindGeneralizeNone ([InvisTVBinder] -> Type -> Type
mkInvisForAllTys [InvisTVBinder]
outer_tv_bndrs (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
mkPhiTy [Type]
theta (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type
tau)
; ((Name, TyVar) -> TcM ()) -> [(Name, TyVar)] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, TyVar) -> TcM ()
emitNamedTypeHole [(Name, TyVar)]
wcs
; [InvisTVBinder]
outer_tv_bndrs <- (InvisTVBinder -> IOEnv (Env TcGblEnv TcLclEnv) InvisTVBinder)
-> [InvisTVBinder] -> TcM [InvisTVBinder]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM InvisTVBinder -> IOEnv (Env TcGblEnv TcLclEnv) InvisTVBinder
forall spec. VarBndr TyVar spec -> TcM (VarBndr TyVar spec)
zonkInvisTVBinder [InvisTVBinder]
outer_tv_bndrs
; [Type]
theta <- (Type -> TcM Type) -> [Type] -> TcM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TcM Type
zonkTcType [Type]
theta
; Type
tau <- Type -> TcM Type
zonkTcType Type
tau
; let outer_bndr_names :: [Name]
outer_bndr_names :: HsQTvsRn
outer_bndr_names = HsOuterSigTyVarBndrs GhcRn -> HsQTvsRn
forall flag. HsOuterTyVarBndrs flag GhcRn -> HsQTvsRn
hsOuterTyVarNames HsOuterSigTyVarBndrs GhcRn
hs_outer_bndrs
tv_prs :: [(Name,InvisTVBinder)]
tv_prs :: [(Name, InvisTVBinder)]
tv_prs = HsQTvsRn
outer_bndr_names HsQTvsRn -> [InvisTVBinder] -> [(Name, InvisTVBinder)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [InvisTVBinder]
outer_tv_bndrs
; String -> SDoc -> TcM ()
traceTc String
"tcHsPartialSigType" ([(Name, InvisTVBinder)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, InvisTVBinder)]
tv_prs)
; ([(Name, TyVar)], Maybe Type, [(Name, InvisTVBinder)], [Type],
Type)
-> TcM
([(Name, TyVar)], Maybe Type, [(Name, InvisTVBinder)], [Type],
Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, TyVar)]
wcs, Maybe Type
wcx, [(Name, InvisTVBinder)]
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 = ([Type], Maybe Type) -> TcM ([Type], Maybe Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe Type
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) <- [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> Maybe
([GenLocated SrcSpanAnnA (HsType GhcRn)],
GenLocated SrcSpanAnnA (HsType GhcRn))
forall a. [a] -> Maybe ([a], a)
snocView [GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_theta
, L SrcSpanAnnA
wc_loc ty :: HsType GhcRn
ty@(HsWildCardTy XWildCardTy GhcRn
_) <- LHsType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsType (GhcPass p) -> LHsType (GhcPass p)
ignoreParens GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
hs_ctxt_last
= do { Type
wc_tv_ty <- SrcSpanAnnA -> TcM Type -> TcM Type
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
wc_loc (TcM Type -> TcM Type) -> TcM Type -> TcM Type
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 <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> TcM Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> TcM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcTyMode -> LHsType GhcRn -> TcM Type
tc_lhs_pred TcTyMode
mode) [GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_theta1
; ([Type], Maybe Type) -> TcM ([Type], Maybe Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
theta, Type -> Maybe Type
forall a. a -> Maybe a
Just Type
wc_tv_ty) }
| Bool
otherwise
= do { [Type]
theta <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> TcM Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)] -> TcM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcTyMode -> LHsType GhcRn -> TcM Type
tc_lhs_pred TcTyMode
mode) [GenLocated SrcSpanAnnA (HsType GhcRn)]
hs_theta
; ([Type], Maybe Type) -> TcM ([Type], Maybe Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
theta, Maybe Type
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
= UserTypeCtxt
-> GenLocated SrcSpanAnnA (HsType GhcRn)
-> TcM ([(Name, TyVar)], [(Name, TyVar)], Type)
-> TcM ([(Name, TyVar)], [(Name, TyVar)], Type)
forall hs_ty a.
Outputable hs_ty =>
UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
hs_ty (TcM ([(Name, TyVar)], [(Name, TyVar)], Type)
-> TcM ([(Name, TyVar)], [(Name, TyVar)], Type))
-> TcM ([(Name, TyVar)], [(Name, TyVar)], Type)
-> TcM ([(Name, TyVar)], [(Name, TyVar)], Type)
forall a b. (a -> b) -> a -> b
$
do { [(Name, TyVar)]
sig_tkv_prs <- (Name -> IOEnv (Env TcGblEnv TcLclEnv) (Name, TyVar))
-> HsQTvsRn -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, TyVar)]
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)
<- LHsType GhcRn
-> TcM ([(Name, TyVar)], Type) -> TcM ([(Name, TyVar)], Type)
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
hs_ty (TcM ([(Name, TyVar)], Type) -> TcM ([(Name, TyVar)], Type))
-> TcM ([(Name, TyVar)], Type) -> TcM ([(Name, TyVar)], Type)
forall a b. (a -> b) -> a -> b
$
String
-> TcM ([(Name, TyVar)], Type) -> TcM ([(Name, TyVar)], Type)
forall a. String -> TcM a -> TcM a
solveEqualities String
"tcHsPatSigType" (TcM ([(Name, TyVar)], Type) -> TcM ([(Name, TyVar)], Type))
-> TcM ([(Name, TyVar)], Type) -> TcM ([(Name, TyVar)], Type)
forall a b. (a -> b) -> a -> b
$
HsQTvsRn
-> ([(Name, TyVar)] -> TcM ([(Name, TyVar)], Type))
-> TcM ([(Name, TyVar)], Type)
forall a. HsQTvsRn -> ([(Name, TyVar)] -> TcM a) -> TcM a
bindNamedWildCardBinders HsQTvsRn
sig_wcs (([(Name, TyVar)] -> TcM ([(Name, TyVar)], Type))
-> TcM ([(Name, TyVar)], Type))
-> ([(Name, TyVar)] -> TcM ([(Name, TyVar)], Type))
-> TcM ([(Name, TyVar)], Type)
forall a b. (a -> b) -> a -> b
$ \ [(Name, TyVar)]
wcs ->
[(Name, TyVar)]
-> TcM ([(Name, TyVar)], Type) -> TcM ([(Name, TyVar)], Type)
forall r. [(Name, TyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TyVar)]
sig_tkv_prs (TcM ([(Name, TyVar)], Type) -> TcM ([(Name, TyVar)], Type))
-> TcM ([(Name, TyVar)], Type) -> TcM ([(Name, TyVar)], Type)
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
; ([(Name, TyVar)], Type) -> TcM ([(Name, TyVar)], Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, TyVar)]
wcs, Type
sig_ty) }
; ((Name, TyVar) -> TcM ()) -> [(Name, TyVar)] -> TcM ()
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" ([(Name, TyVar)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, TyVar)]
sig_tkv_prs)
; ([(Name, TyVar)], [(Name, TyVar)], Type)
-> TcM ([(Name, TyVar)], [(Name, TyVar)], Type)
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 {} -> Name -> Type -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
newSkolemTyVar Name
name Type
kind
UserTypeCtxt
_ -> Name -> Type -> IOEnv (Env TcGblEnv TcLclEnv) TyVar
newPatSigTyVar Name
name Type
kind
; (Name, TyVar) -> IOEnv (Env TcGblEnv TcLclEnv) (Name, TyVar)
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
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (GenLocated SrcSpanAnnA (HsType GhcRn) -> HsType GhcRn
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsType GhcRn)
rn_ty) Type
ty Type
act_kind Type
kind
; [Type]
tys' <- (GenLocated SrcSpanAnnA (HsType GhcRn) -> (Type, Type) -> TcM Type)
-> [GenLocated SrcSpanAnnA (HsType GhcRn)]
-> [(Type, Type)]
-> TcM [Type]
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 [GenLocated SrcSpanAnnA (HsType GhcRn)]
[LHsType GhcRn]
rn_tys [(Type, Type)]
act_kinds
; ([Type], Type) -> TcM ([Type], Type)
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 <- SDoc -> TcM Type -> TcM Type
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (String -> SDoc
text String
"In the kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
hs_kind)) (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
String -> TcM Type -> TcM Type
forall a. String -> TcM a -> TcM a
solveEqualities String
"tcLHsKindSig" (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
hs_kind Type
liftedTypeKind
; String -> SDoc -> TcM ()
traceTc String
"tcLHsKindSig" (GenLocated SrcSpanAnnA (HsType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenLocated SrcSpanAnnA (HsType GhcRn)
LHsType GhcRn
hs_kind SDoc -> SDoc -> SDoc
$$ Type -> SDoc
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" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
kind)
; Type -> TcM Type
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
= SDoc -> TcM a
forall a. SDoc -> TcM a
failWithTc (SDoc -> Arity -> SDoc -> SDoc
hang (PromotionErr -> SDoc
pprPECategory PromotionErr
err SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"cannot be used here")
Arity
2 (SDoc -> SDoc
parens SDoc
reason))
where
reason :: SDoc
reason = case PromotionErr
err of
ConstrainedDataConPE Type
pred
-> String -> SDoc
text String
"it has an unpromotable context"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred)
PromotionErr
FamDataConPE -> String -> SDoc
text String
"it comes from a data family instance"
PromotionErr
NoDataKindsTC -> String -> SDoc
text String
"perhaps you intended to use DataKinds"
PromotionErr
NoDataKindsDC -> String -> SDoc
text String
"perhaps you intended to use DataKinds"
PromotionErr
PatSynPE -> String -> SDoc
text String
"pattern synonyms cannot be promoted"
PromotionErr
RecDataConPE -> SDoc
same_rec_group_msg
PromotionErr
ClassPE -> SDoc
same_rec_group_msg
PromotionErr
TyConPE -> SDoc
same_rec_group_msg
same_rec_group_msg :: SDoc
same_rec_group_msg = String -> SDoc
text String
"it is defined and used in the same recursive group"
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 ([SDoc] -> SDoc
hsep [ String -> SDoc
text String
"In the", Arity -> SDoc
speakNth Arity
arg_no, PtrString -> SDoc
ptext (String -> PtrString
sLit String
"argument of"),
SDoc -> SDoc
quotes (fun -> SDoc
forall a. Outputable a => a -> SDoc
ppr fun
fun) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", namely"])
Arity
2 (SDoc -> SDoc
quotes (arg -> SDoc
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
= SDoc -> TcM a -> TcM a
forall a. SDoc -> TcM a -> TcM a
addErrCtxt (SDoc -> TcM a -> TcM a) -> SDoc -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"In the", TyConFlavour -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyConFlavour
flav
, String -> SDoc
text String
"declaration for", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) ]