{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module TcHsType (
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,
ContextKind(..),
kcLookupTcTyCon, bindTyClTyVars,
etaExpandAlgTyCon, tcbVisibilities,
zonkAndScopedSort,
InitialKindStrategy(..),
SAKS_or_CUSK(..),
kcDeclHeader,
tcNamedWildCardBinders,
tcHsLiftedType, tcHsOpenType,
tcHsLiftedTypeNC, tcHsOpenTypeNC,
tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType,
tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps,
failIfEmitsConstraints,
solveEqualities,
typeLevelMode, kindLevelMode,
kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone,
checkExpectedKind_pp,
tcLHsKindSig, checkDataKindSig, DataSort(..),
checkClassKindSig,
tcHsPatSigType, tcPatSig,
funAppCtxt, addTyConFlavCtxt
) where
#include "HsVersions.h"
import GhcPrelude
import GHC.Hs
import TcRnMonad
import TcOrigin
import Predicate
import Constraint
import TcEvidence
import TcEnv
import TcMType
import TcValidity
import TcUnify
import TcIface
import TcSimplify
import TcHsSyn
import TyCoRep
import TyCoPpr
import TcErrors ( reportAllUnsolved )
import TcType
import Inst ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder )
import Type
import TysPrim
import RdrName( lookupLocalRdrOcc )
import Var
import VarSet
import TyCon
import ConLike
import DataCon
import Class
import Name
import VarEnv
import TysWiredIn
import BasicTypes
import SrcLoc
import Constants ( mAX_CTUPLE_SIZE )
import ErrUtils( MsgDoc )
import Unique
import UniqSet
import Util
import UniqSupply
import Outputable
import FastString
import PrelNames hiding ( wildCardName )
import DynFlags
import qualified GHC.LanguageExtensions as LangExt
import Maybes
import Data.List ( find )
import Control.Monad
funsSigCtxt :: [Located Name] -> UserTypeCtxt
funsSigCtxt :: [Located Name] -> UserTypeCtxt
funsSigCtxt (L SrcSpan
_ Name
name1 : [Located Name]
_) = Name -> Bool -> UserTypeCtxt
FunSigCtxt Name
name1 Bool
False
funsSigCtxt [] = String -> UserTypeCtxt
forall a. String -> a
panic String
"funSigCtxt"
addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a
addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt LHsType GhcRn
hs_ty TcM a
thing_inside
= SrcSpan -> TcM a -> TcM a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (LHsType GhcRn -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsType GhcRn
hs_ty) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
MsgDoc -> TcM a -> TcM a
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (UserTypeCtxt -> LHsType GhcRn -> MsgDoc
pprSigCtxt UserTypeCtxt
ctxt LHsType GhcRn
hs_ty) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc
pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> MsgDoc
pprSigCtxt UserTypeCtxt
ctxt LHsType GhcRn
hs_ty
| Just Name
n <- UserTypeCtxt -> Maybe Name
isSigMaybe UserTypeCtxt
ctxt
= MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"In the type signature:")
Int
2 (Name -> MsgDoc
forall a. OutputableBndr a => a -> MsgDoc
pprPrefixOcc Name
n MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
dcolon MsgDoc -> MsgDoc -> MsgDoc
<+> LHsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsType GhcRn
hs_ty)
| Bool
otherwise
= MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"In" MsgDoc -> MsgDoc -> MsgDoc
<+> UserTypeCtxt -> MsgDoc
pprUserTypeCtxt UserTypeCtxt
ctxt MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon)
Int
2 (LHsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsType GhcRn
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 :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM ()
kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM ()
kcClassSigType SkolemInfo
skol_info [Located Name]
names LHsSigType GhcRn
sig_ty
= TcM Type -> TcM ()
forall a. TcM a -> TcM ()
discardResult (TcM Type -> TcM ()) -> TcM Type -> TcM ()
forall a b. (a -> b) -> a -> b
$
SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type
tcClassSigType SkolemInfo
skol_info [Located Name]
names LHsSigType GhcRn
sig_ty
tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type
tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type
tcClassSigType SkolemInfo
skol_info [Located Name]
names LHsSigType GhcRn
sig_ty
= UserTypeCtxt -> LHsType GhcRn -> TcM Type -> TcM Type
forall a. UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a
addSigCtxt ([Located Name] -> UserTypeCtxt
funsSigCtxt [Located Name]
names) (LHsSigType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
hsSigType LHsSigType GhcRn
sig_ty) (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
(Bool, Type) -> Type
forall a b. (a, b) -> b
snd ((Bool, Type) -> Type)
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Type) -> TcM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SkolemInfo
-> LHsSigType GhcRn
-> ContextKind
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Type)
tc_hs_sig_type SkolemInfo
skol_info LHsSigType GhcRn
sig_ty (Type -> ContextKind
TheKind Type
liftedTypeKind)
tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
tcHsSigType UserTypeCtxt
ctxt LHsSigType GhcRn
sig_ty
= UserTypeCtxt -> LHsType GhcRn -> TcM Type -> TcM Type
forall a. UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt (LHsSigType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
hsSigType LHsSigType GhcRn
sig_ty) (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
do { String -> MsgDoc -> TcM ()
traceTc String
"tcHsSigType {" (LHsSigType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsSigType GhcRn
sig_ty)
; (Bool
insol, Type
ty) <- SkolemInfo
-> LHsSigType GhcRn
-> ContextKind
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Type)
tc_hs_sig_type SkolemInfo
skol_info LHsSigType GhcRn
sig_ty
(UserTypeCtxt -> ContextKind
expectedKindInCtxt UserTypeCtxt
ctxt)
; Type
ty <- Type -> TcM Type
zonkTcType Type
ty
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
insol TcM ()
forall env a. IOEnv env a
failM
; UserTypeCtxt -> Type -> TcM ()
checkValidType UserTypeCtxt
ctxt Type
ty
; String -> MsgDoc -> TcM ()
traceTc String
"end tcHsSigType }" (Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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
tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)
tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Type)
tcStandaloneKindSig (L SrcSpan
_ StandaloneKindSig GhcRn
kisig) = case StandaloneKindSig GhcRn
kisig of
StandaloneKindSig XStandaloneKindSig GhcRn
_ (L SrcSpan
_ IdP GhcRn
name) LHsSigType GhcRn
ksig ->
let ctxt :: UserTypeCtxt
ctxt = Name -> UserTypeCtxt
StandaloneKindSigCtxt Name
IdP GhcRn
name in
UserTypeCtxt
-> LHsType GhcRn -> TcM (Name, Type) -> TcM (Name, Type)
forall a. UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a
addSigCtxt UserTypeCtxt
ctxt (LHsSigType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
hsSigType 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 <- TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type
tcTopLHsType TcTyMode
kindLevelMode LHsSigType GhcRn
ksig (UserTypeCtxt -> ContextKind
expectedKindInCtxt UserTypeCtxt
ctxt)
; UserTypeCtxt -> Type -> TcM ()
checkValidType UserTypeCtxt
ctxt Type
kind
; (Name, Type) -> TcM (Name, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
IdP GhcRn
name, Type
kind) }
XStandaloneKindSig XXStandaloneKindSig GhcRn
nec -> NoExtCon -> TcM (Name, Type)
forall a. NoExtCon -> a
noExtCon XXStandaloneKindSig GhcRn
NoExtCon
nec
tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn
-> ContextKind -> TcM (Bool, TcType)
tc_hs_sig_type :: SkolemInfo
-> LHsSigType GhcRn
-> ContextKind
-> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Type)
tc_hs_sig_type SkolemInfo
skol_info LHsSigType GhcRn
hs_sig_type ContextKind
ctxt_kind
| HsIB { hsib_ext :: forall pass thing. HsImplicitBndrs pass thing -> XHsIB pass thing
hsib_ext = XHsIB GhcRn (LHsType GhcRn)
sig_vars, hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = LHsType GhcRn
hs_ty } <- LHsSigType GhcRn
hs_sig_type
= do { (TcLevel
tc_lvl, (WantedConstraints
wanted, ([TcTyVar]
spec_tkvs, Type
ty)))
<- TcM (WantedConstraints, ([TcTyVar], Type))
-> TcM (TcLevel, (WantedConstraints, ([TcTyVar], Type)))
forall a. TcM a -> TcM (TcLevel, a)
pushTcLevelM (TcM (WantedConstraints, ([TcTyVar], Type))
-> TcM (TcLevel, (WantedConstraints, ([TcTyVar], Type))))
-> TcM (WantedConstraints, ([TcTyVar], Type))
-> TcM (TcLevel, (WantedConstraints, ([TcTyVar], Type)))
forall a b. (a -> b) -> a -> b
$
String
-> TcM ([TcTyVar], Type)
-> TcM (WantedConstraints, ([TcTyVar], Type))
forall a. String -> TcM a -> TcM (WantedConstraints, a)
solveLocalEqualitiesX String
"tc_hs_sig_type" (TcM ([TcTyVar], Type)
-> TcM (WantedConstraints, ([TcTyVar], Type)))
-> TcM ([TcTyVar], Type)
-> TcM (WantedConstraints, ([TcTyVar], Type))
forall a b. (a -> b) -> a -> b
$
[Name] -> TcM Type -> TcM ([TcTyVar], Type)
forall a. [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Skol [Name]
XHsIB GhcRn (LHsType GhcRn)
sig_vars (TcM Type -> TcM ([TcTyVar], Type))
-> TcM Type -> TcM ([TcTyVar], Type)
forall a b. (a -> b) -> a -> b
$
do { Type
kind <- ContextKind -> TcM Type
newExpectedKind ContextKind
ctxt_kind
; TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
typeLevelMode LHsType GhcRn
hs_ty Type
kind }
; [TcTyVar]
spec_tkvs <- [TcTyVar] -> TcM [TcTyVar]
zonkAndScopedSort [TcTyVar]
spec_tkvs
; let ty1 :: Type
ty1 = [TcTyVar] -> Type -> Type
mkSpecForAllTys [TcTyVar]
spec_tkvs Type
ty
; TyCoVarSet
constrained <- TyCoVarSet -> TcM TyCoVarSet
zonkTyCoVarsAndFV (WantedConstraints -> TyCoVarSet
tyCoVarsOfWC WantedConstraints
wanted)
; let should_gen :: TcTyVar -> Bool
should_gen = Bool -> Bool
not (Bool -> Bool) -> (TcTyVar -> Bool) -> TcTyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TcTyVar -> TyCoVarSet -> Bool
`elemVarSet` TyCoVarSet
constrained)
; [TcTyVar]
kvs <- (TcTyVar -> Bool) -> Type -> TcM [TcTyVar]
kindGeneralizeSome TcTyVar -> Bool
should_gen Type
ty1
; SkolemInfo
-> Maybe MsgDoc
-> [TcTyVar]
-> TcLevel
-> WantedConstraints
-> TcM ()
emitResidualTvConstraint SkolemInfo
skol_info Maybe MsgDoc
forall a. Maybe a
Nothing ([TcTyVar]
kvs [TcTyVar] -> [TcTyVar] -> [TcTyVar]
forall a. [a] -> [a] -> [a]
++ [TcTyVar]
spec_tkvs)
TcLevel
tc_lvl WantedConstraints
wanted
; (Bool, Type) -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (WantedConstraints -> Bool
insolubleWC WantedConstraints
wanted, [TcTyVar] -> Type -> Type
mkInvForAllTys [TcTyVar]
kvs Type
ty1) }
tc_hs_sig_type SkolemInfo
_ (XHsImplicitBndrs XXHsImplicitBndrs GhcRn (LHsType GhcRn)
nec) ContextKind
_ = NoExtCon -> IOEnv (Env TcGblEnv TcLclEnv) (Bool, Type)
forall a. NoExtCon -> a
noExtCon XXHsImplicitBndrs GhcRn (LHsType GhcRn)
NoExtCon
nec
tcTopLHsType :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type
tcTopLHsType :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type
tcTopLHsType TcTyMode
mode LHsSigType GhcRn
hs_sig_type ContextKind
ctxt_kind
| HsIB { hsib_ext :: forall pass thing. HsImplicitBndrs pass thing -> XHsIB pass thing
hsib_ext = XHsIB GhcRn (LHsType GhcRn)
sig_vars, hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = LHsType GhcRn
hs_ty } <- LHsSigType GhcRn
hs_sig_type
= do { String -> MsgDoc -> TcM ()
traceTc String
"tcTopLHsType {" (LHsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsType GhcRn
hs_ty)
; ([TcTyVar]
spec_tkvs, Type
ty)
<- TcM ([TcTyVar], Type) -> TcM ([TcTyVar], Type)
forall a. TcM a -> TcM a
pushTcLevelM_ (TcM ([TcTyVar], Type) -> TcM ([TcTyVar], Type))
-> TcM ([TcTyVar], Type) -> TcM ([TcTyVar], Type)
forall a b. (a -> b) -> a -> b
$
TcM ([TcTyVar], Type) -> TcM ([TcTyVar], Type)
forall a. TcM a -> TcM a
solveEqualities (TcM ([TcTyVar], Type) -> TcM ([TcTyVar], Type))
-> TcM ([TcTyVar], Type) -> TcM ([TcTyVar], Type)
forall a b. (a -> b) -> a -> b
$
[Name] -> TcM Type -> TcM ([TcTyVar], Type)
forall a. [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Skol [Name]
XHsIB GhcRn (LHsType GhcRn)
sig_vars (TcM Type -> TcM ([TcTyVar], Type))
-> TcM Type -> TcM ([TcTyVar], Type)
forall a b. (a -> b) -> a -> b
$
do { Type
kind <- ContextKind -> TcM Type
newExpectedKind ContextKind
ctxt_kind
; TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
hs_ty Type
kind }
; [TcTyVar]
spec_tkvs <- [TcTyVar] -> TcM [TcTyVar]
zonkAndScopedSort [TcTyVar]
spec_tkvs
; let ty1 :: Type
ty1 = [TcTyVar] -> Type -> Type
mkSpecForAllTys [TcTyVar]
spec_tkvs Type
ty
; [TcTyVar]
kvs <- Type -> TcM [TcTyVar]
kindGeneralizeAll Type
ty1
; Type
final_ty <- Type -> TcM Type
zonkTcTypeToType ([TcTyVar] -> Type -> Type
mkInvForAllTys [TcTyVar]
kvs Type
ty1)
; String -> MsgDoc -> TcM ()
traceTc String
"End tcTopLHsType }" ([MsgDoc] -> MsgDoc
vcat [LHsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsType GhcRn
hs_ty, Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
final_ty])
; Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
final_ty}
tcTopLHsType TcTyMode
_ (XHsImplicitBndrs XXHsImplicitBndrs GhcRn (LHsType GhcRn)
nec) ContextKind
_ = NoExtCon -> TcM Type
forall a. NoExtCon -> a
noExtCon XXHsImplicitBndrs GhcRn (LHsType GhcRn)
NoExtCon
nec
tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])
tcHsDeriv :: LHsSigType GhcRn -> TcM ([TcTyVar], Class, [Type], [Type])
tcHsDeriv LHsSigType GhcRn
hs_ty
= do { Type
ty <- TcM Type -> TcM Type
forall a. TcM a -> TcM a
checkNoErrs (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type
tcTopLHsType TcTyMode
typeLevelMode LHsSigType GhcRn
hs_ty ContextKind
AnyKind
; let ([TcTyVar]
tvs, Type
pred) = Type -> ([TcTyVar], Type)
splitForAllTys Type
ty
([Type]
kind_args, Type
_) = Type -> ([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) -> ([TcTyVar], Class, [Type], [Type])
-> TcM ([TcTyVar], Class, [Type], [Type])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TcTyVar]
tvs, Class
cls, [Type]
tys, [Type]
kind_args)
Maybe (Class, [Type])
Nothing -> MsgDoc -> TcM ([TcTyVar], Class, [Type], [Type])
forall a. MsgDoc -> TcM a
failWithTc (String -> MsgDoc
text String
"Illegal deriving item" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (LHsSigType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsSigType GhcRn
hs_ty)) }
tcDerivStrategy ::
Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])
tcDerivStrategy :: Maybe (LDerivStrategy GhcRn)
-> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar])
tcDerivStrategy Maybe (LDerivStrategy GhcRn)
mb_lds
= case Maybe (LDerivStrategy GhcRn)
mb_lds of
Maybe (LDerivStrategy GhcRn)
Nothing -> Maybe (LDerivStrategy GhcTc)
-> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar])
forall ds. ds -> TcM (ds, [TcTyVar])
boring_case Maybe (LDerivStrategy GhcTc)
forall a. Maybe a
Nothing
Just (LDerivStrategy GhcRn
-> Located (SrcSpanLess (LDerivStrategy GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LDerivStrategy GhcRn)
ds) ->
SrcSpan
-> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar])
-> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar])
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar])
-> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar]))
-> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar])
-> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar])
forall a b. (a -> b) -> a -> b
$ do
(DerivStrategy GhcTc
ds', [TcTyVar]
tvs) <- DerivStrategy GhcRn -> TcM (DerivStrategy GhcTc, [TcTyVar])
tc_deriv_strategy SrcSpanLess (LDerivStrategy GhcRn)
DerivStrategy GhcRn
ds
(Maybe (LDerivStrategy GhcTc), [TcTyVar])
-> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LDerivStrategy GhcTc -> Maybe (LDerivStrategy GhcTc)
forall a. a -> Maybe a
Just (SrcSpan
-> SrcSpanLess (LDerivStrategy GhcTc) -> LDerivStrategy GhcTc
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LDerivStrategy GhcTc)
DerivStrategy GhcTc
ds'), [TcTyVar]
tvs)
where
tc_deriv_strategy :: DerivStrategy GhcRn
-> TcM (DerivStrategy GhcTc, [TyVar])
tc_deriv_strategy :: DerivStrategy GhcRn -> TcM (DerivStrategy GhcTc, [TcTyVar])
tc_deriv_strategy DerivStrategy GhcRn
StockStrategy = DerivStrategy GhcTc -> TcM (DerivStrategy GhcTc, [TcTyVar])
forall ds. ds -> TcM (ds, [TcTyVar])
boring_case DerivStrategy GhcTc
forall pass. DerivStrategy pass
StockStrategy
tc_deriv_strategy DerivStrategy GhcRn
AnyclassStrategy = DerivStrategy GhcTc -> TcM (DerivStrategy GhcTc, [TcTyVar])
forall ds. ds -> TcM (ds, [TcTyVar])
boring_case DerivStrategy GhcTc
forall pass. DerivStrategy pass
AnyclassStrategy
tc_deriv_strategy DerivStrategy GhcRn
NewtypeStrategy = DerivStrategy GhcTc -> TcM (DerivStrategy GhcTc, [TcTyVar])
forall ds. ds -> TcM (ds, [TcTyVar])
boring_case DerivStrategy GhcTc
forall pass. DerivStrategy pass
NewtypeStrategy
tc_deriv_strategy (ViaStrategy XViaStrategy GhcRn
ty) = do
Type
ty' <- TcM Type -> TcM Type
forall a. TcM a -> TcM a
checkNoErrs (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$ TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type
tcTopLHsType TcTyMode
typeLevelMode XViaStrategy GhcRn
LHsSigType GhcRn
ty ContextKind
AnyKind
let ([TcTyVar]
via_tvs, Type
via_pred) = Type -> ([TcTyVar], Type)
splitForAllTys Type
ty'
(DerivStrategy GhcTc, [TcTyVar])
-> TcM (DerivStrategy GhcTc, [TcTyVar])
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, [TcTyVar]
via_tvs)
boring_case :: ds -> TcM (ds, [TyVar])
boring_case :: ds -> TcM (ds, [TcTyVar])
boring_case ds
ds = (ds, [TcTyVar]) -> TcM (ds, [TcTyVar])
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 (LHsType GhcRn -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc (LHsSigType GhcRn -> LHsType GhcRn
forall (p :: Pass). LHsSigType (GhcPass p) -> LHsType (GhcPass p)
hsSigType 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 a. TcM a -> TcM a
checkNoErrs (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type
tcTopLHsType TcTyMode
typeLevelMode LHsSigType GhcRn
hs_inst_ty (Type -> ContextKind
TheKind Type
constraintKind)
; 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 { Type
ty <- String -> TcM Type -> TcM Type
forall a. String -> TcM a -> TcM a
solveLocalEqualities String
"tcHsTypeApp" (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
WarningFlag -> TcM Type -> TcM Type
forall gbl lcl a.
WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM WarningFlag
Opt_WarnPartialTypeSignatures (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
Extension -> TcM Type -> TcM Type
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.PartialTypeSignatures (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
[Name] -> ([(Name, TcTyVar)] -> TcM Type) -> TcM Type
forall a. [Name] -> ([(Name, TcTyVar)] -> TcM a) -> TcM a
tcNamedWildCardBinders [Name]
XHsWC GhcRn (LHsType GhcRn)
sig_wcs (([(Name, TcTyVar)] -> TcM Type) -> TcM Type)
-> ([(Name, TcTyVar)] -> TcM Type) -> TcM Type
forall a b. (a -> b) -> a -> b
$ \ [(Name, TcTyVar)]
_ ->
LHsType GhcRn -> Type -> TcM Type
tcCheckLHsType 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 }
tcHsTypeApp (XHsWildCardBndrs XXHsWildCardBndrs GhcRn (LHsType GhcRn)
nec) Type
_ = NoExtCon -> TcM Type
forall a. NoExtCon -> a
noExtCon XXHsWildCardBndrs GhcRn (LHsType GhcRn)
NoExtCon
nec
tcHsOpenType, tcHsLiftedType,
tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType
tcHsOpenType :: LHsType GhcRn -> TcM Type
tcHsOpenType LHsType GhcRn
ty = LHsType GhcRn -> TcM Type -> TcM Type
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> TcM Type
tcHsOpenTypeNC LHsType GhcRn
ty
tcHsLiftedType :: LHsType GhcRn -> TcM Type
tcHsLiftedType LHsType GhcRn
ty = LHsType GhcRn -> TcM Type -> TcM Type
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
ty (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$ LHsType GhcRn -> TcM Type
tcHsLiftedTypeNC LHsType GhcRn
ty
tcHsOpenTypeNC :: LHsType GhcRn -> TcM Type
tcHsOpenTypeNC LHsType GhcRn
ty = do { Type
ek <- TcM Type
newOpenTypeKind
; TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
typeLevelMode LHsType GhcRn
ty Type
ek }
tcHsLiftedTypeNC :: LHsType GhcRn -> TcM Type
tcHsLiftedTypeNC LHsType GhcRn
ty = TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
typeLevelMode LHsType GhcRn
ty Type
liftedTypeKind
tcCheckLHsType :: LHsType GhcRn -> Kind -> TcM TcType
tcCheckLHsType :: LHsType GhcRn -> Type -> TcM Type
tcCheckLHsType LHsType GhcRn
hs_ty Type
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
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
typeLevelMode LHsType GhcRn
hs_ty Type
exp_kind
tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind)
tcLHsType :: LHsType GhcRn -> TcM (Type, Type)
tcLHsType LHsType GhcRn
ty = LHsType GhcRn -> TcM (Type, Type) -> TcM (Type, Type)
forall a. LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt LHsType GhcRn
ty (TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
typeLevelMode LHsType GhcRn
ty)
tcLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)
tcLHsTypeUnsaturated :: LHsType GhcRn -> TcM (Type, Type)
tcLHsTypeUnsaturated LHsType GhcRn
hs_ty
| Just (LHsType GhcRn
hs_fun_ty, [LHsTypeArg GhcRn]
hs_args) <- HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])
splitHsAppTys (LHsType GhcRn -> SrcSpanLess (LHsType GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc 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 { (Type
fun_ty, Type
_ki) <- TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tcInferAppHead TcTyMode
mode LHsType GhcRn
hs_fun_ty
; TcTyMode
-> LHsType GhcRn -> Type -> [LHsTypeArg GhcRn] -> TcM (Type, Type)
tcInferApps_nosat TcTyMode
mode LHsType GhcRn
hs_fun_ty Type
fun_ty [LHsTypeArg GhcRn]
hs_args }
| Bool
otherwise
= 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
$
TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode LHsType GhcRn
hs_ty
where
mode :: TcTyMode
mode = TcTyMode
typeLevelMode
data TcTyMode = TcTyMode { TcTyMode -> TypeOrKind
mode_level :: TypeOrKind }
typeLevelMode :: TcTyMode
typeLevelMode :: TcTyMode
typeLevelMode = TcTyMode :: TypeOrKind -> TcTyMode
TcTyMode { mode_level :: TypeOrKind
mode_level = TypeOrKind
TypeLevel }
kindLevelMode :: TcTyMode
kindLevelMode :: TcTyMode
kindLevelMode = TcTyMode :: TypeOrKind -> TcTyMode
TcTyMode { mode_level :: TypeOrKind
mode_level = TypeOrKind
KindLevel }
kindLevel :: TcTyMode -> TcTyMode
kindLevel :: TcTyMode -> TcTyMode
kindLevel TcTyMode
mode = TcTyMode
mode { mode_level :: TypeOrKind
mode_level = TypeOrKind
KindLevel }
instance Outputable TcTyMode where
ppr :: TcTyMode -> MsgDoc
ppr = TypeOrKind -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (TypeOrKind -> MsgDoc)
-> (TcTyMode -> TypeOrKind) -> TcTyMode -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcTyMode -> TypeOrKind
mode_level
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 SrcSpan
span HsType GhcRn
ty)
= SrcSpan -> TcM (Type, Type) -> TcM (Type, Type)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
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 :: 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, [LHsTypeArg GhcRn]
hs_args) <- HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])
splitHsAppTys HsType GhcRn
ty
= do { (Type
fun_ty, Type
_ki) <- TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tcInferAppHead TcTyMode
mode LHsType GhcRn
hs_fun_ty
; TcTyMode
-> LHsType GhcRn -> Type -> [LHsTypeArg GhcRn] -> TcM (Type, Type)
tcInferApps TcTyMode
mode LHsType GhcRn
hs_fun_ty Type
fun_ty [LHsTypeArg GhcRn]
hs_args }
tc_infer_hs_type TcTyMode
mode (HsKindSig XKindSig GhcRn
_ LHsType GhcRn
ty LHsType GhcRn
sig)
= do { Type
sig' <- UserTypeCtxt -> LHsType GhcRn -> TcM Type
tcLHsKindSig UserTypeCtxt
KindSigCtxt LHsType GhcRn
sig
; String -> MsgDoc -> TcM ()
traceTc String
"tc_infer_hs_type:sig" (LHsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsType GhcRn
ty MsgDoc -> MsgDoc -> MsgDoc
$$ Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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 (NHsCoreTy 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)
| [LHsType GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsType GhcRn]
tys
= (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Type
mkTyConTy TyCon
promotedNilDataCon,
[TcTyVar] -> Type -> Type
mkSpecForAllTys [TcTyVar
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) }
tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType
tc_lhs_type :: TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode (L SrcSpan
span HsType GhcRn
ty) Type
exp_kind
= SrcSpan -> TcM Type -> TcM Type
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
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 = MsgDoc -> TcM Type
forall a. MsgDoc -> TcM a
failWith (MsgDoc -> TcM Type) -> MsgDoc -> TcM Type
forall a b. (a -> b) -> a -> b
$
String -> MsgDoc
text String
"Unexpected" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
err MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"annotation:" MsgDoc -> MsgDoc -> MsgDoc
<+> HsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcRn
ty MsgDoc -> MsgDoc -> MsgDoc
$$
String -> MsgDoc
text String
err MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
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
_
= MsgDoc -> TcM Type
forall a. MsgDoc -> TcM a
failWithTc (String -> MsgDoc
text String
"Record syntax is illegal here:" MsgDoc -> MsgDoc -> MsgDoc
<+> HsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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
= MsgDoc -> TcM Type
forall a. MsgDoc -> TcM a
failWithTc (String -> MsgDoc
text String
"Unexpected type splice:" MsgDoc -> MsgDoc -> MsgDoc
<+> HsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcRn
ty)
tc_hs_type TcTyMode
mode (HsFunTy XFunTy GhcRn
_ LHsType GhcRn
ty1 LHsType GhcRn
ty2) Type
exp_kind
= TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> Type -> TcM Type
tc_fun_type TcTyMode
mode LHsType GhcRn
ty1 LHsType GhcRn
ty2 Type
exp_kind
tc_hs_type TcTyMode
mode (HsOpTy XOpTy GhcRn
_ LHsType GhcRn
ty1 (L SrcSpan
_ IdP GhcRn
op) LHsType GhcRn
ty2) Type
exp_kind
| Name
IdP GhcRn
op Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
funTyConKey
= TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> Type -> TcM Type
tc_fun_type TcTyMode
mode LHsType GhcRn
ty1 LHsType GhcRn
ty2 Type
exp_kind
tc_hs_type TcTyMode
mode forall :: HsType GhcRn
forall@(HsForAllTy { hst_fvf :: forall pass. HsType pass -> ForallVisFlag
hst_fvf = ForallVisFlag
fvf, hst_bndrs :: forall pass. HsType pass -> [LHsTyVarBndr pass]
hst_bndrs = [LHsTyVarBndr GhcRn]
hs_tvs
, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
ty }) Type
exp_kind
= do { (TcLevel
tclvl, WantedConstraints
wanted, ([TcTyVar]
tvs', Type
ty'))
<- TcM ([TcTyVar], Type)
-> TcM (TcLevel, WantedConstraints, ([TcTyVar], Type))
forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints (TcM ([TcTyVar], Type)
-> TcM (TcLevel, WantedConstraints, ([TcTyVar], Type)))
-> TcM ([TcTyVar], Type)
-> TcM (TcLevel, WantedConstraints, ([TcTyVar], Type))
forall a b. (a -> b) -> a -> b
$
[LHsTyVarBndr GhcRn] -> TcM Type -> TcM ([TcTyVar], Type)
forall a. [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
bindExplicitTKBndrs_Skol [LHsTyVarBndr GhcRn]
hs_tvs (TcM Type -> TcM ([TcTyVar], Type))
-> TcM Type -> TcM ([TcTyVar], 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
; let argf :: ArgFlag
argf = case ForallVisFlag
fvf of
ForallVisFlag
ForallVis -> ArgFlag
Required
ForallVisFlag
ForallInvis -> ArgFlag
Specified
bndrs :: [TyVarBinder]
bndrs = ArgFlag -> [TcTyVar] -> [TyVarBinder]
mkTyVarBinders ArgFlag
argf [TcTyVar]
tvs'
skol_info :: SkolemInfo
skol_info = MsgDoc -> SkolemInfo
ForAllSkol (HsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcRn
forall)
m_telescope :: Maybe MsgDoc
m_telescope = MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just ([MsgDoc] -> MsgDoc
sep ((LHsTyVarBndr GhcRn -> MsgDoc) -> [LHsTyVarBndr GhcRn] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [LHsTyVarBndr GhcRn]
hs_tvs))
; SkolemInfo
-> Maybe MsgDoc
-> [TcTyVar]
-> TcLevel
-> WantedConstraints
-> TcM ()
emitResidualTvConstraint SkolemInfo
skol_info Maybe MsgDoc
m_telescope [TcTyVar]
tvs' TcLevel
tclvl WantedConstraints
wanted
; Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
bndrs Type
ty') }
tc_hs_type TcTyMode
mode (HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = LHsContext GhcRn
ctxt, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcRn
rn_ty }) Type
exp_kind
| [LHsType GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (LHsContext GhcRn -> SrcSpanLess (LHsContext GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc 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 -> LHsContext GhcRn -> TcM [Type]
tc_hs_context TcTyMode
mode LHsContext GhcRn
ctxt
; Type
ty' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
rn_ty Type
constraintKind
; Type -> TcM Type
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Type -> Type
mkPhiTy [Type]
ctxt' Type
ty') }
| Bool
otherwise
= do { [Type]
ctxt' <- TcTyMode -> LHsContext GhcRn -> TcM [Type]
tc_hs_context TcTyMode
mode LHsContext GhcRn
ctxt
; Type
ek <- TcM Type
newOpenTypeKind
; Type
ty' <- TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
rn_ty Type
ek
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (LHsType GhcRn -> SrcSpanLess (LHsType GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc 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 -> MsgDoc -> TcM ()
traceTc String
"tc_hs_type tuple" ([LHsType GhcRn] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [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 -> MsgDoc -> TcM ()
traceTc String
"tc_hs_type tuple 2" ([LHsType GhcRn] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [LHsType GhcRn]
hs_tys)
; ([Type]
tys, [Type]
kinds) <- (LHsType GhcRn -> TcM (Type, Type))
-> [LHsType GhcRn]
-> IOEnv (Env TcGblEnv TcLclEnv) ([Type], [Type])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode) [LHsType GhcRn]
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 [ SrcSpan -> TcM Type -> TcM Type
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
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 SrcSpan
loc HsType GhcRn
hs_ty),Type
ty,Type
kind) <- [LHsType GhcRn]
-> [Type] -> [Type] -> [(LHsType GhcRn, Type, Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [LHsType GhcRn]
hs_tys [Type]
tys [Type]
kinds ]
; HsType GhcRn -> TupleSort -> [Type] -> [Type] -> Type -> TcM Type
finish_tuple HsType GhcRn
rn_ty TupleSort
tup_sort [Type]
tys' ((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
hs_tup_sort [LHsType GhcRn]
tys) Type
exp_kind
= 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
where
tup_sort :: TupleSort
tup_sort = case HsTupleSort
hs_tup_sort of
HsTupleSort
HsUnboxedTuple -> TupleSort
UnboxedTuple
HsTupleSort
HsBoxedTuple -> TupleSort
BoxedTuple
HsTupleSort
HsConstraintTuple -> TupleSort
ConstraintTuple
HsTupleSort
_ -> String -> TupleSort
forall a. String -> a
panic String
"tc_hs_type HsTupleTy"
tc_hs_type TcTyMode
mode rn_ty :: HsType GhcRn
rn_ty@(HsSumTy XSumTy GhcRn
_ [LHsType GhcRn]
hs_tys) Type
exp_kind
= do { let arity :: Int
arity = [LHsType GhcRn] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType GhcRn]
hs_tys
; [Type]
arg_kinds <- (LHsType GhcRn -> TcM Type) -> [LHsType GhcRn] -> TcM [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\LHsType GhcRn
_ -> TcM Type
newOpenTypeKind) [LHsType GhcRn]
hs_tys
; [Type]
tau_tys <- (LHsType GhcRn -> Type -> TcM Type)
-> [LHsType GhcRn] -> [Type] -> TcM [Type]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode) [LHsType GhcRn]
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 (Int -> TyCon
sumTyCon Int
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 <- (LHsType GhcRn -> TcM (Type, Type))
-> [LHsType 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) [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 <- Int -> TcM Type -> TcM [Type]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
arity TcM Type
newMetaKindVar
; [Type]
taus <- (LHsType GhcRn -> Type -> TcM Type)
-> [LHsType GhcRn] -> [Type] -> TcM [Type]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode) [LHsType GhcRn]
tys [Type]
ks
; let kind_con :: TyCon
kind_con = Boxity -> Int -> TyCon
tupleTyCon Boxity
Boxed Int
arity
ty_con :: TyCon
ty_con = Boxity -> Int -> TyCon
promotedTupleDataCon Boxity
Boxed Int
arity
tup_k :: Type
tup_k = TyCon -> [Type] -> Type
mkTyConApp TyCon
kind_con [Type]
ks
; 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 :: Int
arity = [LHsType GhcRn] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [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_level 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
typeNatKindCon
; 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
typeNatKind 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
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 (NHsCoreTy{})) 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
_ wc :: HsType GhcRn
wc@(HsWildCardTy XWildCardTy GhcRn
_) Type
ek = HsType GhcRn -> Type -> TcM Type
tcAnonWildCardOcc HsType GhcRn
wc Type
ek
tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind
-> TcM TcType
tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> Type -> TcM Type
tc_fun_type TcTyMode
mode LHsType GhcRn
ty1 LHsType GhcRn
ty2 Type
exp_kind = case TcTyMode -> TypeOrKind
mode_level 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
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (XFunTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcRn
NoExtField
noExtField LHsType GhcRn
ty1 LHsType GhcRn
ty2) (Type -> Type -> Type
mkVisFunTy 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
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind (XFunTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcRn
NoExtField
noExtField LHsType GhcRn
ty1 LHsType GhcRn
ty2) (Type -> Type -> Type
mkVisFunTy Type
ty1' Type
ty2')
Type
liftedTypeKind Type
exp_kind }
tcAnonWildCardOcc :: HsType GhcRn -> Kind -> TcM TcType
tcAnonWildCardOcc :: HsType GhcRn -> Type -> TcM Type
tcAnonWildCardOcc HsType GhcRn
wc Type
exp_kind
= do { TcTyVar
wc_tv <- TcM TcTyVar
newWildTyVar
; Bool
part_tysig <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PartialTypeSignatures
; Bool
warning <- WarningFlag -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnPartialTypeSignatures
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
part_tysig Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
warning) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
TcTyVar -> TcM ()
emitAnonWildCardHoleConstraint TcTyVar
wc_tv
; HasDebugCallStack =>
HsType GhcRn -> Type -> Type -> Type -> TcM Type
HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
wc (TcTyVar -> Type
mkTyVarTy TcTyVar
wc_tv)
(TcTyVar -> Type
tyVarKind TcTyVar
wc_tv) 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 (Int -> Type -> [Type]
forall a. Int -> a -> [a]
replicate Int
arity Type
liftedTypeKind)
TupleSort
UnboxedTuple -> Int -> TcM Type -> TcM [Type]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
arity TcM Type
newOpenTypeKind
TupleSort
ConstraintTuple -> [Type] -> TcM [Type]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Type -> [Type]
forall a. Int -> a -> [a]
replicate Int
arity Type
constraintKind)
; [Type]
tau_tys <- (LHsType GhcRn -> Type -> TcM Type)
-> [LHsType GhcRn] -> [Type] -> TcM [Type]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode) [LHsType GhcRn]
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 :: Int
arity = [LHsType GhcRn] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LHsType GhcRn]
tys
finish_tuple :: HsType GhcRn
-> TupleSort
-> [TcType]
-> [TcKind]
-> TcKind
-> TcM TcType
finish_tuple :: HsType GhcRn -> TupleSort -> [Type] -> [Type] -> Type -> TcM Type
finish_tuple HsType GhcRn
rn_ty TupleSort
tup_sort [Type]
tau_tys [Type]
tau_kinds Type
exp_kind = do
String -> MsgDoc -> TcM ()
traceTc String
"finish_tuple" (TupleSort -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr TupleSort
tup_sort MsgDoc -> MsgDoc -> MsgDoc
$$ [Type] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Type]
tau_kinds MsgDoc -> MsgDoc -> MsgDoc
$$ Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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
| Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
mAX_CTUPLE_SIZE
-> MsgDoc -> TcM Type
forall a. MsgDoc -> TcM a
failWith (Int -> MsgDoc
bigConstraintTuple Int
arity)
| Bool
otherwise
-> do TyCon
tycon <- Name -> TcM TyCon
tcLookupTyCon (Int -> Name
cTupleTyConName Int
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 -> Int -> TyCon
tupleTyCon Boxity
Boxed Int
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 ->
let tycon :: TyCon
tycon = Boxity -> Int -> TyCon
tupleTyCon Boxity
Unboxed Int
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 in
Type -> Type -> TcM Type
check_expected_kind (TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type]
arg_tys) Type
res_kind
where
arity :: Int
arity = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
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
bigConstraintTuple :: Arity -> MsgDoc
bigConstraintTuple :: Int -> MsgDoc
bigConstraintTuple Int
arity
= MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Constraint tuple arity too large:" MsgDoc -> MsgDoc -> MsgDoc
<+> Int -> MsgDoc
int Int
arity
MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
parens (String -> MsgDoc
text String
"max arity =" MsgDoc -> MsgDoc -> MsgDoc
<+> Int -> MsgDoc
int Int
mAX_CTUPLE_SIZE))
Int
2 (String -> MsgDoc
text String
"Instead, use a nested tuple")
splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])
splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])
splitHsAppTys HsType GhcRn
hs_ty
| HsType GhcRn -> Bool
is_app HsType GhcRn
hs_ty = (LHsType GhcRn, [LHsTypeArg GhcRn])
-> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])
forall a. a -> Maybe a
Just (LHsType GhcRn
-> [LHsTypeArg GhcRn] -> (LHsType GhcRn, [LHsTypeArg GhcRn])
forall pass.
(XTyVar pass ~ NoExtField, XAppKindTy pass ~ SrcSpan) =>
LHsType pass
-> [HsArg (LHsType pass) (LHsType pass)]
-> (LHsType pass, [HsArg (LHsType pass) (LHsType pass)])
go (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (LHsType GhcRn)
HsType GhcRn
hs_ty) [])
| Bool
otherwise = Maybe (LHsType GhcRn, [LHsTypeArg 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 SrcSpan
_ IdP GhcRn
op) LHsType GhcRn
_) = Bool -> Bool
not (Name
IdP GhcRn
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 SrcSpan
_ HsType GhcRn
ty)) = HsType GhcRn -> Bool
is_app HsType GhcRn
ty
is_app HsType GhcRn
_ = Bool
False
go :: LHsType pass
-> [HsArg (LHsType pass) (LHsType pass)]
-> (LHsType pass, [HsArg (LHsType pass) (LHsType pass)])
go (L SrcSpan
_ (HsAppTy XAppTy pass
_ LHsType pass
f LHsType pass
a)) [HsArg (LHsType pass) (LHsType pass)]
as = LHsType pass
-> [HsArg (LHsType pass) (LHsType pass)]
-> (LHsType pass, [HsArg (LHsType pass) (LHsType pass)])
go LHsType pass
f (LHsType pass -> HsArg (LHsType pass) (LHsType pass)
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType pass
a HsArg (LHsType pass) (LHsType pass)
-> [HsArg (LHsType pass) (LHsType pass)]
-> [HsArg (LHsType pass) (LHsType pass)]
forall a. a -> [a] -> [a]
: [HsArg (LHsType pass) (LHsType pass)]
as)
go (L SrcSpan
_ (HsAppKindTy XAppKindTy pass
l LHsType pass
ty LHsType pass
k)) [HsArg (LHsType pass) (LHsType pass)]
as = LHsType pass
-> [HsArg (LHsType pass) (LHsType pass)]
-> (LHsType pass, [HsArg (LHsType pass) (LHsType pass)])
go LHsType pass
ty (SrcSpan -> LHsType pass -> HsArg (LHsType pass) (LHsType pass)
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
XAppKindTy pass
l LHsType pass
k HsArg (LHsType pass) (LHsType pass)
-> [HsArg (LHsType pass) (LHsType pass)]
-> [HsArg (LHsType pass) (LHsType pass)]
forall a. a -> [a] -> [a]
: [HsArg (LHsType pass) (LHsType pass)]
as)
go (L SrcSpan
sp (HsParTy XParTy pass
_ LHsType pass
f)) [HsArg (LHsType pass) (LHsType pass)]
as = LHsType pass
-> [HsArg (LHsType pass) (LHsType pass)]
-> (LHsType pass, [HsArg (LHsType pass) (LHsType pass)])
go LHsType pass
f (SrcSpan -> HsArg (LHsType pass) (LHsType pass)
forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar SrcSpan
sp HsArg (LHsType pass) (LHsType pass)
-> [HsArg (LHsType pass) (LHsType pass)]
-> [HsArg (LHsType pass) (LHsType pass)]
forall a. a -> [a] -> [a]
: [HsArg (LHsType pass) (LHsType pass)]
as)
go (L SrcSpan
_ (HsOpTy XOpTy pass
_ LHsType pass
l op :: Located (IdP pass)
op@(L SrcSpan
sp IdP pass
_) LHsType pass
r)) [HsArg (LHsType pass) (LHsType pass)]
as
= ( SrcSpan -> HsType pass -> LHsType pass
forall l e. l -> e -> GenLocated l e
L SrcSpan
sp (XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar pass
NoExtField
noExtField PromotionFlag
NotPromoted Located (IdP pass)
op)
, LHsType pass -> HsArg (LHsType pass) (LHsType pass)
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType pass
l HsArg (LHsType pass) (LHsType pass)
-> [HsArg (LHsType pass) (LHsType pass)]
-> [HsArg (LHsType pass) (LHsType pass)]
forall a. a -> [a] -> [a]
: LHsType pass -> HsArg (LHsType pass) (LHsType pass)
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType pass
r HsArg (LHsType pass) (LHsType pass)
-> [HsArg (LHsType pass) (LHsType pass)]
-> [HsArg (LHsType pass) (LHsType pass)]
forall a. a -> [a] -> [a]
: [HsArg (LHsType pass) (LHsType pass)]
as )
go LHsType pass
f [HsArg (LHsType pass) (LHsType pass)]
as = (LHsType pass
f, [HsArg (LHsType pass) (LHsType pass)]
as)
tcInferAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)
tcInferAppHead :: TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tcInferAppHead TcTyMode
mode (L SrcSpan
_ (HsTyVar XTyVar GhcRn
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcRn
tv)))
= TcTyMode -> Name -> TcM (Type, Type)
tcTyVar TcTyMode
mode Name
IdP GhcRn
tv
tcInferAppHead TcTyMode
mode LHsType GhcRn
ty
= TcTyMode -> LHsType GhcRn -> TcM (Type, Type)
tc_infer_lhs_type TcTyMode
mode LHsType GhcRn
ty
tcInferApps, tcInferApps_nosat
:: TcTyMode
-> LHsType GhcRn
-> TcType
-> [LHsTypeArg GhcRn]
-> TcM (TcType, TcKind)
tcInferApps :: TcTyMode
-> LHsType GhcRn -> Type -> [LHsTypeArg GhcRn] -> TcM (Type, Type)
tcInferApps TcTyMode
mode LHsType GhcRn
hs_ty Type
fun [LHsTypeArg GhcRn]
hs_args
= do { (Type
f_args, Type
res_k) <- TcTyMode
-> LHsType GhcRn -> Type -> [LHsTypeArg GhcRn] -> TcM (Type, Type)
tcInferApps_nosat TcTyMode
mode LHsType GhcRn
hs_ty Type
fun [LHsTypeArg GhcRn]
hs_args
; Type -> Type -> TcM (Type, Type)
saturateFamApp Type
f_args Type
res_k }
tcInferApps_nosat :: TcTyMode
-> LHsType GhcRn -> Type -> [LHsTypeArg GhcRn] -> TcM (Type, Type)
tcInferApps_nosat TcTyMode
mode LHsType GhcRn
orig_hs_ty Type
fun [LHsTypeArg GhcRn]
orig_hs_args
= do { String -> MsgDoc -> TcM ()
traceTc String
"tcInferApps {" (LHsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsType GhcRn
orig_hs_ty MsgDoc -> MsgDoc -> MsgDoc
$$ [LHsTypeArg GhcRn] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [LHsTypeArg GhcRn]
orig_hs_args)
; (Type
f_args, Type
res_k) <- Int -> Type -> [LHsTypeArg GhcRn] -> TcM (Type, Type)
go_init Int
1 Type
fun [LHsTypeArg GhcRn]
orig_hs_args
; String -> MsgDoc -> TcM ()
traceTc String
"tcInferApps }" (Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
f_args MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
dcolon MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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 :: Int -> Type -> [LHsTypeArg GhcRn] -> TcM (Type, Type)
go_init Int
n Type
fun [LHsTypeArg GhcRn]
all_args
= Int
-> Type
-> TCvSubst
-> Type
-> [LHsTypeArg GhcRn]
-> TcM (Type, Type)
go Int
n Type
fun TCvSubst
empty_subst Type
fun_ki [LHsTypeArg 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
$ TyCoVarSet -> InScopeSet
mkInScopeSet (TyCoVarSet -> InScopeSet) -> TyCoVarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$
Type -> TyCoVarSet
tyCoVarsOfType Type
fun_ki
go :: Int
-> TcType
-> TCvSubst
-> TcKind
-> [LHsTypeArg GhcRn]
-> TcM (TcType, TcKind)
go :: Int
-> Type
-> TCvSubst
-> Type
-> [LHsTypeArg GhcRn]
-> TcM (Type, Type)
go Int
n Type
fun TCvSubst
subst Type
fun_ki [LHsTypeArg GhcRn]
all_args = case ([LHsTypeArg 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
_ : [LHsTypeArg GhcRn]
args, Maybe (TyBinder, Type)
_) -> Int
-> Type
-> TCvSubst
-> Type
-> [LHsTypeArg GhcRn]
-> TcM (Type, Type)
go Int
n Type
fun TCvSubst
subst Type
fun_ki [LHsTypeArg GhcRn]
args
(HsTypeArg SrcSpan
_ LHsType GhcRn
hs_ki_arg : [LHsTypeArg GhcRn]
hs_args, Just (TyBinder
ki_binder, Type
inner_ki)) ->
case TyBinder
ki_binder of
Named (Bndr TcTyVar
_ ArgFlag
Inferred) -> TyBinder -> Type -> TcM (Type, Type)
instantiate TyBinder
ki_binder Type
inner_ki
Anon AnonArgFlag
InvisArg Type
_ -> TyBinder -> Type -> TcM (Type, Type)
instantiate TyBinder
ki_binder Type
inner_ki
Named (Bndr TcTyVar
_ ArgFlag
Specified) ->
do { String -> MsgDoc -> TcM ()
traceTc String
"tcInferApps (vis kind app)"
([MsgDoc] -> MsgDoc
vcat [ TyBinder -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr TyBinder
ki_binder, LHsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsType GhcRn
hs_ki_arg
, Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (TyBinder -> Type
tyBinderType TyBinder
ki_binder)
, TCvSubst -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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
ki_arg <- MsgDoc -> TcM Type -> TcM Type
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (LHsType GhcRn -> LHsType GhcRn -> Int -> MsgDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Int -> MsgDoc
funAppCtxt LHsType GhcRn
orig_hs_ty LHsType GhcRn
hs_ki_arg Int
n) (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
WarningFlag -> TcM Type -> TcM Type
forall gbl lcl a.
WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM WarningFlag
Opt_WarnPartialTypeSignatures (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
Extension -> TcM Type -> TcM Type
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.PartialTypeSignatures (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 -> TcTyMode
kindLevel TcTyMode
mode) LHsType GhcRn
hs_ki_arg Type
exp_kind
; String -> MsgDoc -> TcM ()
traceTc String
"tcInferApps (vis kind app)" (Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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
; Int
-> Type
-> TCvSubst
-> Type
-> [LHsTypeArg GhcRn]
-> TcM (Type, Type)
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Type
fun' TCvSubst
subst' Type
inner_ki [LHsTypeArg GhcRn]
hs_args }
TyBinder
_ -> LHsType GhcRn -> Type -> TcM (Type, Type)
forall a a a. (Outputable a, Outputable a) => a -> a -> TcRn a
ty_app_err LHsType 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
_ LHsType GhcRn
ki_arg : [LHsTypeArg 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
$
LHsType GhcRn -> Type -> TcM (Type, Type)
forall a a a. (Outputable a, Outputable a) => a -> a -> TcRn a
ty_app_err LHsType GhcRn
ki_arg Type
substed_fun_ki
(HsValArg LHsType GhcRn
arg : [LHsTypeArg 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 -> MsgDoc -> TcM ()
traceTc String
"tcInferApps (vis normal app)"
([MsgDoc] -> MsgDoc
vcat [ TyBinder -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr TyBinder
ki_binder
, LHsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsType GhcRn
arg
, Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (TyBinder -> Type
tyBinderType TyBinder
ki_binder)
, TCvSubst -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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' <- MsgDoc -> TcM Type -> TcM Type
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt (LHsType GhcRn -> LHsType GhcRn -> Int -> MsgDoc
forall fun arg.
(Outputable fun, Outputable arg) =>
fun -> arg -> Int -> MsgDoc
funAppCtxt LHsType GhcRn
orig_hs_ty LHsType GhcRn
arg Int
n) (TcM Type -> TcM Type) -> TcM Type -> TcM Type
forall a b. (a -> b) -> a -> b
$
TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
arg Type
exp_kind
; String -> MsgDoc -> TcM ()
traceTc String
"tcInferApps (vis normal app) 2" (Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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'
; Int
-> Type
-> TCvSubst
-> Type
-> [LHsTypeArg GhcRn]
-> TcM (Type, Type)
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Type
fun' TCvSubst
subst' Type
inner_ki [LHsTypeArg GhcRn]
args }
(HsValArg LHsType GhcRn
_ : [LHsTypeArg 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 :: Int
arrows_needed = [LHsTypeArg GhcRn] -> Int
forall tm ty. [HsArg tm ty] -> Int
n_initial_val_args [LHsTypeArg GhcRn]
all_args
; Coercion
co <- LHsType GhcRn -> Int -> Type -> TcM Coercion
forall fun. Outputable fun => fun -> Int -> Type -> TcM Coercion
matchExpectedFunKind LHsType GhcRn
hs_ty Int
arrows_needed Type
substed_fun_ki
; Type
fun' <- Type -> TcM Type
zonkTcType (Type
fun Type -> Coercion -> Type
`mkTcCastTy` Coercion
co)
; String -> MsgDoc -> TcM ()
traceTc String
"tcInferApps (no binder)" (MsgDoc -> TcM ()) -> MsgDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[MsgDoc] -> MsgDoc
vcat [ Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
fun MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
dcolon MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
fun_ki
, Int -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Int
arrows_needed
, Coercion -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Coercion
co
, Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
fun' MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
dcolon MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
fun')]
; Int -> Type -> [LHsTypeArg GhcRn] -> TcM (Type, Type)
go_init Int
n Type
fun' [LHsTypeArg GhcRn]
all_args }
where
instantiate :: TyBinder -> Type -> TcM (Type, Type)
instantiate TyBinder
ki_binder Type
inner_ki
= do { String -> MsgDoc -> TcM ()
traceTc String
"tcInferApps (need to instantiate)"
([MsgDoc] -> MsgDoc
vcat [ TyBinder -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr TyBinder
ki_binder, TCvSubst -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr TCvSubst
subst])
; (TCvSubst
subst', Type
arg') <- TCvSubst -> TyBinder -> TcM (TCvSubst, Type)
tcInstInvisibleTyBinder TCvSubst
subst TyBinder
ki_binder
; Int
-> Type
-> TCvSubst
-> Type
-> [LHsTypeArg GhcRn]
-> TcM (Type, Type)
go Int
n (Type -> Type -> Type
mkAppTy Type
fun Type
arg') TCvSubst
subst' Type
inner_ki [LHsTypeArg 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)
= Int
-> Type
-> TCvSubst
-> Type
-> [LHsTypeArg GhcRn]
-> TcM (Type, Type)
go Int
n Type
fun TCvSubst
zapped_subst Type
substed_fun_ki [LHsTypeArg 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 -> [LHsTypeArg GhcRn] -> LHsType GhcRn
appTypeToArg LHsType GhcRn
orig_hs_ty (Int -> [LHsTypeArg GhcRn] -> [LHsTypeArg GhcRn]
forall a. Int -> [a] -> [a]
take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [LHsTypeArg GhcRn]
orig_hs_args)
n_initial_val_args :: [HsArg tm ty] -> Arity
n_initial_val_args :: [HsArg tm ty] -> Int
n_initial_val_args (HsValArg {} : [HsArg tm ty]
args) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [HsArg tm ty] -> Int
forall tm ty. [HsArg tm ty] -> Int
n_initial_val_args [HsArg tm ty]
args
n_initial_val_args (HsArgPar {} : [HsArg tm ty]
args) = [HsArg tm ty] -> Int
forall tm ty. [HsArg tm ty] -> Int
n_initial_val_args [HsArg tm ty]
args
n_initial_val_args [HsArg tm ty]
_ = Int
0
ty_app_err :: a -> a -> TcRn a
ty_app_err a
arg a
ty
= MsgDoc -> TcRn a
forall a. MsgDoc -> TcM a
failWith (MsgDoc -> TcRn a) -> MsgDoc -> TcRn a
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text String
"Cannot apply function of kind" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr a
ty)
MsgDoc -> MsgDoc -> MsgDoc
$$ String -> MsgDoc
text String
"to visible kind argument" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` (TyCon -> Int
tyConArity TyCon
tc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
, (TcTyVar -> Bool) -> [TcTyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TcTyVar -> Bool
isTrickyTvBinder (TyCon -> [TcTyVar]
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 TcTyVar
tv ArgFlag
_) -> TCvSubst -> TcTyVar -> Type -> TCvSubst
extendTvSubstAndInScope TCvSubst
subst TcTyVar
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 TcTyVar
tv ArgFlag
_)) Type
arg
= do { Type
arg' <- if TcTyVar -> Bool
isTrickyTvBinder TcTyVar
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 -> TcTyVar -> Type -> TCvSubst
extendTvSubstAndInScope TCvSubst
subst TcTyVar
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 :: TcTyVar -> Bool
isTrickyTvBinder TcTyVar
tv = Type -> Bool
isPiTy (TcTyVar -> Type
tyVarKind TcTyVar
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 :: Int
n_to_inst = TyCon -> Int
tyConArity TyCon
tc Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args
= do { ([Type]
extra_args, Type
ki') <- Int -> Type -> TcM ([Type], Type)
tcInstInvisibleTyBinders Int
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 -> [LHsTypeArg GhcRn] -> LHsType GhcRn
appTypeToArg LHsType GhcRn
f [] = LHsType GhcRn
f
appTypeToArg LHsType GhcRn
f (HsValArg LHsType GhcRn
arg : [LHsTypeArg GhcRn]
args) = LHsType GhcRn -> [LHsTypeArg 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) [LHsTypeArg GhcRn]
args
appTypeToArg LHsType GhcRn
f (HsArgPar SrcSpan
_ : [LHsTypeArg GhcRn]
args) = LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn
appTypeToArg LHsType GhcRn
f [LHsTypeArg GhcRn]
args
appTypeToArg LHsType GhcRn
f (HsTypeArg SrcSpan
l LHsType GhcRn
arg : [LHsTypeArg GhcRn]
args)
= LHsType GhcRn -> [LHsTypeArg 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) [LHsTypeArg GhcRn]
args
checkExpectedKind :: HasDebugCallStack
=> HsType GhcRn
-> TcType
-> TcKind
-> TcKind
-> TcM TcType
checkExpectedKind :: HsType GhcRn -> Type -> Type -> Type -> TcM Type
checkExpectedKind HsType GhcRn
hs_ty Type
ty Type
act Type
exp
= HasDebugCallStack => MsgDoc -> Type -> Type -> Type -> TcM Type
MsgDoc -> Type -> Type -> Type -> TcM Type
checkExpectedKind_pp (HsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcRn
hs_ty) Type
ty Type
act Type
exp
checkExpectedKind_pp :: HasDebugCallStack
=> SDoc
-> TcType
-> TcKind
-> TcKind
-> TcM TcType
checkExpectedKind_pp :: MsgDoc -> Type -> Type -> Type -> TcM Type
checkExpectedKind_pp MsgDoc
pp_hs_ty Type
ty Type
act_kind Type
exp_kind
= do { String -> MsgDoc -> TcM ()
traceTc String
"checkExpectedKind" (Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
ty MsgDoc -> MsgDoc -> MsgDoc
$$ Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
act_kind)
; ([Type]
new_args, Type
act_kind') <- Int -> Type -> TcM ([Type], Type)
tcInstInvisibleTyBinders Int
n_to_inst Type
act_kind
; let origin :: CtOrigin
origin = TypeEqOrigin :: Type -> Type -> Maybe MsgDoc -> Bool -> CtOrigin
TypeEqOrigin { uo_actual :: Type
uo_actual = Type
act_kind'
, uo_expected :: Type
uo_expected = Type
exp_kind
, uo_thing :: Maybe MsgDoc
uo_thing = MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
pp_hs_ty
, uo_visible :: Bool
uo_visible = Bool
True }
; String -> MsgDoc -> TcM ()
traceTc String
"checkExpectedKindX" (MsgDoc -> TcM ()) -> MsgDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[MsgDoc] -> MsgDoc
vcat [ MsgDoc
pp_hs_ty
, String -> MsgDoc
text String
"act_kind':" MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
act_kind'
, String -> MsgDoc
text String
"exp_kind:" MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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 -> MsgDoc -> TcM ()
traceTc String
"checkExpectedKind" ([MsgDoc] -> MsgDoc
vcat [ Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
act_kind
, Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
exp_kind
, Coercion -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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 :: Int
n_exp_invis_bndrs = Type -> Int
invisibleTyBndrCount Type
exp_kind
n_act_invis_bndrs :: Int
n_act_invis_bndrs = Type -> Int
invisibleTyBndrCount Type
act_kind
n_to_inst :: Int
n_to_inst = Int
n_act_invis_bndrs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_exp_invis_bndrs
tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]
tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [Type]
tcHsMbContext Maybe (LHsContext GhcRn)
Nothing = [Type] -> TcM [Type]
forall (m :: * -> *) a. Monad m => a -> m a
return []
tcHsMbContext (Just LHsContext GhcRn
cxt) = LHsContext GhcRn -> TcM [Type]
tcHsContext LHsContext GhcRn
cxt
tcHsContext :: LHsContext GhcRn -> TcM [PredType]
tcHsContext :: LHsContext GhcRn -> TcM [Type]
tcHsContext = TcTyMode -> LHsContext GhcRn -> TcM [Type]
tc_hs_context TcTyMode
typeLevelMode
tcLHsPredType :: LHsType GhcRn -> TcM PredType
tcLHsPredType :: LHsType GhcRn -> TcM Type
tcLHsPredType = TcTyMode -> LHsType GhcRn -> TcM Type
tc_lhs_pred TcTyMode
typeLevelMode
tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]
tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [Type]
tc_hs_context TcTyMode
mode LHsContext GhcRn
ctxt = (LHsType GhcRn -> TcM Type) -> [LHsType 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) (LHsContext GhcRn -> SrcSpanLess (LHsContext GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsContext GhcRn
ctxt)
tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType
tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM Type
tc_lhs_pred TcTyMode
mode LHsType GhcRn
pred = TcTyMode -> LHsType GhcRn -> Type -> TcM Type
tc_lhs_type TcTyMode
mode LHsType GhcRn
pred Type
constraintKind
tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind)
tcTyVar :: TcTyMode -> Name -> TcM (Type, Type)
tcTyVar TcTyMode
mode Name
name
= do { String -> MsgDoc -> TcM ()
traceTc String
"lk1" (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name)
; TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
name
; case TcTyThing
thing of
ATyVar Name
_ TcTyVar
tv -> (Type, Type) -> TcM (Type, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyVar -> Type
mkTyVarTy TcTyVar
tv, TcTyVar -> Type
tyVarKind TcTyVar
tv)
ATcTyCon TyCon
tc_tc
-> do {
Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TypeOrKind -> Bool
isTypeLevel (TcTyMode -> TypeOrKind
mode_level TcTyMode
mode))
(Name -> PromotionErr -> TcM ()
forall a. Name -> PromotionErr -> TcM a
promotionErr Name
name PromotionErr
TyConPE)
; 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 ([TcTyVar]
_, [TcTyVar]
_, [EqSpec]
_, [Type]
theta, [Type]
_, Type
_) = DataCon -> ([TcTyVar], [TcTyVar], [EqSpec], [Type], [Type], Type)
dataConFullSig DataCon
dc
; String -> MsgDoc -> TcM ()
traceTc String
"tcTyVar" (DataCon -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr DataCon
dc MsgDoc -> MsgDoc -> MsgDoc
<+> [Type] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Type]
theta MsgDoc -> MsgDoc -> MsgDoc
$$ Maybe Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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_level 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 :: LHsType GhcRn -> TcM a -> TcM a
addTypeCtxt (L SrcSpan
_ (HsWildCardTy XWildCardTy GhcRn
_)) TcM a
thing = TcM a
thing
addTypeCtxt (L SrcSpan
_ HsType GhcRn
ty) TcM a
thing
= MsgDoc -> TcM a -> TcM a
forall a. MsgDoc -> TcM a -> TcM a
addErrCtxt MsgDoc
doc TcM a
thing
where
doc :: MsgDoc
doc = String -> MsgDoc
text String
"In the type" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsType GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcRn
ty)
tcNamedWildCardBinders :: [Name]
-> ([(Name, TcTyVar)] -> TcM a)
-> TcM a
tcNamedWildCardBinders :: [Name] -> ([(Name, TcTyVar)] -> TcM a) -> TcM a
tcNamedWildCardBinders [Name]
wc_names [(Name, TcTyVar)] -> TcM a
thing_inside
= do { [TcTyVar]
wcs <- (Name -> TcM TcTyVar) -> [Name] -> TcM [TcTyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcM TcTyVar -> Name -> TcM TcTyVar
forall a b. a -> b -> a
const TcM TcTyVar
newWildTyVar) [Name]
wc_names
; let wc_prs :: [(Name, TcTyVar)]
wc_prs = [Name]
wc_names [Name] -> [TcTyVar] -> [(Name, TcTyVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcTyVar]
wcs
; [(Name, TcTyVar)] -> TcM a -> TcM a
forall r. [(Name, TcTyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TcTyVar)]
wc_prs (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
[(Name, TcTyVar)] -> TcM a
thing_inside [(Name, TcTyVar)]
wc_prs }
newWildTyVar :: TcM TcTyVar
newWildTyVar :: TcM TcTyVar
newWildTyVar
= do { Type
kind <- TcM Type
newMetaKindVar
; Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; TcTyVarDetails
details <- MetaInfo -> TcM TcTyVarDetails
newMetaDetails MetaInfo
TauTv
; let name :: Name
name = Unique -> FastString -> Name
mkSysTvName Unique
uniq (String -> FastString
fsLit String
"_")
tyvar :: TcTyVar
tyvar = Name -> Type -> TcTyVarDetails -> TcTyVar
mkTcTyVar Name
name Type
kind TcTyVarDetails
details
; String -> MsgDoc -> TcM ()
traceTc String
"newWildTyVar" (TcTyVar -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr TcTyVar
tyvar)
; TcTyVar -> TcM TcTyVar
forall (m :: * -> *) a. Monad m => a -> m a
return TcTyVar
tyvar }
data InitialKindStrategy
= InitialKindCheck SAKS_or_CUSK
| InitialKindInfer
data SAKS_or_CUSK
= SAKS Kind
| CUSK
instance Outputable SAKS_or_CUSK where
ppr :: SAKS_or_CUSK -> MsgDoc
ppr (SAKS Type
k) = String -> MsgDoc
text String
"SAKS" MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
k
ppr SAKS_or_CUSK
CUSK = String -> MsgDoc
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 { ([TcTyVar]
scoped_kvs, ([TcTyVar]
tc_tvs, Type
res_kind))
<- TcM ([TcTyVar], ([TcTyVar], Type))
-> TcM ([TcTyVar], ([TcTyVar], Type))
forall a. TcM a -> TcM a
pushTcLevelM_ (TcM ([TcTyVar], ([TcTyVar], Type))
-> TcM ([TcTyVar], ([TcTyVar], Type)))
-> TcM ([TcTyVar], ([TcTyVar], Type))
-> TcM ([TcTyVar], ([TcTyVar], Type))
forall a b. (a -> b) -> a -> b
$
TcM ([TcTyVar], ([TcTyVar], Type))
-> TcM ([TcTyVar], ([TcTyVar], Type))
forall a. TcM a -> TcM a
solveEqualities (TcM ([TcTyVar], ([TcTyVar], Type))
-> TcM ([TcTyVar], ([TcTyVar], Type)))
-> TcM ([TcTyVar], ([TcTyVar], Type))
-> TcM ([TcTyVar], ([TcTyVar], Type))
forall a b. (a -> b) -> a -> b
$
[Name]
-> TcM ([TcTyVar], Type) -> TcM ([TcTyVar], ([TcTyVar], Type))
forall a. [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Q_Skol [Name]
XHsQTvs GhcRn
kv_ns (TcM ([TcTyVar], Type) -> TcM ([TcTyVar], ([TcTyVar], Type)))
-> TcM ([TcTyVar], Type) -> TcM ([TcTyVar], ([TcTyVar], Type))
forall a b. (a -> b) -> a -> b
$
ContextKind
-> [LHsTyVarBndr GhcRn] -> TcM Type -> TcM ([TcTyVar], Type)
forall a.
ContextKind -> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
bindExplicitTKBndrs_Q_Skol ContextKind
ctxt_kind [LHsTyVarBndr GhcRn]
hs_tvs (TcM Type -> TcM ([TcTyVar], Type))
-> TcM Type -> TcM ([TcTyVar], 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 :: [TcTyVar]
spec_req_tkvs = [TcTyVar]
scoped_kvs [TcTyVar] -> [TcTyVar] -> [TcTyVar]
forall a. [a] -> [a] -> [a]
++ [TcTyVar]
tc_tvs
all_kinds :: [Type]
all_kinds = Type
res_kind Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (TcTyVar -> Type) -> [TcTyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TcTyVar -> Type
tyVarKind [TcTyVar]
spec_req_tkvs
; CandidatesQTvs
candidates' <- [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfKinds [Type]
all_kinds
; let non_tc_candidates :: [TcTyVar]
non_tc_candidates = (TcTyVar -> Bool) -> [TcTyVar] -> [TcTyVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (TcTyVar -> Bool) -> TcTyVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcTyVar -> Bool
isTcTyVar) (TyCoVarSet -> [TcTyVar]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet ([Type] -> TyCoVarSet
tyCoVarsOfTypes [Type]
all_kinds))
candidates :: CandidatesQTvs
candidates = CandidatesQTvs
candidates' { dv_kvs :: DTyVarSet
dv_kvs = CandidatesQTvs -> DTyVarSet
dv_kvs CandidatesQTvs
candidates' DTyVarSet -> [TcTyVar] -> DTyVarSet
`extendDVarSetList` [TcTyVar]
non_tc_candidates }
inf_candidates :: CandidatesQTvs
inf_candidates = CandidatesQTvs
candidates CandidatesQTvs -> [TcTyVar] -> CandidatesQTvs
`delCandidates` [TcTyVar]
spec_req_tkvs
; [TcTyVar]
inferred <- CandidatesQTvs -> TcM [TcTyVar]
quantifyTyVars CandidatesQTvs
inf_candidates
; [TcTyVar]
scoped_kvs <- (TcTyVar -> TcM TcTyVar) -> [TcTyVar] -> TcM [TcTyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TcTyVar -> TcM TcTyVar
zonkTyCoVarKind [TcTyVar]
scoped_kvs
; [TcTyVar]
tc_tvs <- (TcTyVar -> TcM TcTyVar) -> [TcTyVar] -> TcM [TcTyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TcTyVar -> TcM TcTyVar
zonkTyCoVarKind [TcTyVar]
tc_tvs
; Type
res_kind <- Type -> TcM Type
zonkTcType Type
res_kind
; let mentioned_kv_set :: TyCoVarSet
mentioned_kv_set = CandidatesQTvs -> TyCoVarSet
candidateKindVars CandidatesQTvs
candidates
specified :: [TcTyVar]
specified = [TcTyVar] -> [TcTyVar]
scopedSort [TcTyVar]
scoped_kvs
final_tc_binders :: [TyConBinder]
final_tc_binders = ArgFlag -> [TcTyVar] -> [TyConBinder]
mkNamedTyConBinders ArgFlag
Inferred [TcTyVar]
inferred
[TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
++ ArgFlag -> [TcTyVar] -> [TyConBinder]
mkNamedTyConBinders ArgFlag
Specified [TcTyVar]
specified
[TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
++ (TcTyVar -> TyConBinder) -> [TcTyVar] -> [TyConBinder]
forall a b. (a -> b) -> [a] -> [b]
map (TyCoVarSet -> TcTyVar -> TyConBinder
mkRequiredTyConBinder TyCoVarSet
mentioned_kv_set) [TcTyVar]
tc_tvs
all_tv_prs :: [(Name, TcTyVar)]
all_tv_prs = [TcTyVar] -> [(Name, TcTyVar)]
mkTyVarNamePairs ([TcTyVar]
scoped_kvs [TcTyVar] -> [TcTyVar] -> [TcTyVar]
forall a. [a] -> [a] -> [a]
++ [TcTyVar]
tc_tvs)
tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Type
-> [(Name, TcTyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon Name
name [TyConBinder]
final_tc_binders Type
res_kind [(Name, TcTyVar)]
all_tv_prs
Bool
True
TyConFlavour
flav
; TyCon -> TcM ()
checkTyConTelescope TyCon
tycon
; String -> MsgDoc -> TcM ()
traceTc String
"kcCheckDeclHeader_cusk " (MsgDoc -> TcM ()) -> MsgDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"name" MsgDoc -> MsgDoc -> MsgDoc
<+> Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name
, String -> MsgDoc
text String
"kv_ns" MsgDoc -> MsgDoc -> MsgDoc
<+> [Name] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Name]
XHsQTvs GhcRn
kv_ns
, String -> MsgDoc
text String
"hs_tvs" MsgDoc -> MsgDoc -> MsgDoc
<+> [LHsTyVarBndr GhcRn] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [LHsTyVarBndr GhcRn]
hs_tvs
, String -> MsgDoc
text String
"scoped_kvs" MsgDoc -> MsgDoc -> MsgDoc
<+> [TcTyVar] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [TcTyVar]
scoped_kvs
, String -> MsgDoc
text String
"tc_tvs" MsgDoc -> MsgDoc -> MsgDoc
<+> [TcTyVar] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [TcTyVar]
tc_tvs
, String -> MsgDoc
text String
"res_kind" MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
res_kind
, String -> MsgDoc
text String
"candidates" MsgDoc -> MsgDoc -> MsgDoc
<+> CandidatesQTvs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr CandidatesQTvs
candidates
, String -> MsgDoc
text String
"inferred" MsgDoc -> MsgDoc -> MsgDoc
<+> [TcTyVar] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [TcTyVar]
inferred
, String -> MsgDoc
text String
"specified" MsgDoc -> MsgDoc -> MsgDoc
<+> [TcTyVar] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [TcTyVar]
specified
, String -> MsgDoc
text String
"final_tc_binders" MsgDoc -> MsgDoc -> MsgDoc
<+> [TyConBinder] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [TyConBinder]
final_tc_binders
, String -> MsgDoc
text String
"mkTyConKind final_tc_bndrs res_kind"
MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ([TyConBinder] -> Type -> Type
mkTyConKind [TyConBinder]
final_tc_binders Type
res_kind)
, String -> MsgDoc
text String
"all_tv_prs" MsgDoc -> MsgDoc -> MsgDoc
<+> [(Name, TcTyVar)] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [(Name, TcTyVar)]
all_tv_prs ]
; 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_cusk Name
_ TyConFlavour
_ (XLHsQTyVars XXLHsQTyVars GhcRn
nec) TcM ContextKind
_ = NoExtCon -> TcM TyCon
forall a. NoExtCon -> a
noExtCon XXLHsQTyVars GhcRn
NoExtCon
nec
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
= do { ([TcTyVar]
scoped_kvs, ([TcTyVar]
tc_tvs, Type
res_kind))
<- [Name]
-> TcM ([TcTyVar], Type) -> TcM ([TcTyVar], ([TcTyVar], Type))
forall a. [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Q_Tv [Name]
XHsQTvs GhcRn
kv_ns (TcM ([TcTyVar], Type) -> TcM ([TcTyVar], ([TcTyVar], Type)))
-> TcM ([TcTyVar], Type) -> TcM ([TcTyVar], ([TcTyVar], Type))
forall a b. (a -> b) -> a -> b
$
ContextKind
-> [LHsTyVarBndr GhcRn] -> TcM Type -> TcM ([TcTyVar], Type)
forall a.
ContextKind -> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
bindExplicitTKBndrs_Q_Tv ContextKind
ctxt_kind [LHsTyVarBndr GhcRn]
hs_tvs (TcM Type -> TcM ([TcTyVar], Type))
-> TcM Type -> TcM ([TcTyVar], 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 -> [TcTyVar] -> [TyConBinder]
mkAnonTyConBinders AnonArgFlag
VisArg [TcTyVar]
tc_tvs
all_tv_prs :: [(Name, TcTyVar)]
all_tv_prs = [TcTyVar] -> [(Name, TcTyVar)]
mkTyVarNamePairs ([TcTyVar]
scoped_kvs [TcTyVar] -> [TcTyVar] -> [TcTyVar]
forall a. [a] -> [a] -> [a]
++ [TcTyVar]
tc_tvs)
tycon :: TyCon
tycon = Name
-> [TyConBinder]
-> Type
-> [(Name, TcTyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon Name
name [TyConBinder]
tc_binders Type
res_kind [(Name, TcTyVar)]
all_tv_prs
Bool
False
TyConFlavour
flav
; String -> MsgDoc -> TcM ()
traceTc String
"kcInferDeclHeader: not-cusk" (MsgDoc -> TcM ()) -> MsgDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[MsgDoc] -> MsgDoc
vcat [ Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name, [Name] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Name]
XHsQTvs GhcRn
kv_ns, [LHsTyVarBndr GhcRn] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [LHsTyVarBndr GhcRn]
hs_tvs
, [TcTyVar] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [TcTyVar]
scoped_kvs
, [TcTyVar] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [TcTyVar]
tc_tvs, Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
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
kcInferDeclHeader Name
_ TyConFlavour
_ (XLHsQTyVars XXLHsQTyVars GhcRn
nec) TcM ContextKind
_ = NoExtCon -> TcM TyCon
forall a. NoExtCon -> a
noExtCon XXLHsQTyVars GhcRn
NoExtCon
nec
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 ([LHsTyVarBndr GhcRn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr GhcRn]
excess_bndrs) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> TcM ()
forall a. MsgDoc -> TcM a
failWithTc (Type -> [LHsTyVarBndr GhcRn] -> MsgDoc
tooManyBindersErr Type
kisig' [LHsTyVarBndr GhcRn]
excess_bndrs)
; ([TyConBinder]
vis_tcbs, [[(Name, TcTyVar)]] -> [(Name, TcTyVar)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat -> [(Name, TcTyVar)]
explicit_tv_prs) <- (ZippedBinder
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TcTyVar)]))
-> [ZippedBinder]
-> IOEnv
(Env TcGblEnv TcLclEnv) ([TyConBinder], [[(Name, TcTyVar)]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM ZippedBinder
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TcTyVar)])
zipped_to_tcb [ZippedBinder]
zipped_binders
; ([TcTyVar]
implicit_tvs, ([TyBinder]
invis_binders, Type
r_ki))
<- TcM ([TcTyVar], ([TyBinder], Type))
-> TcM ([TcTyVar], ([TyBinder], Type))
forall a. TcM a -> TcM a
pushTcLevelM_ (TcM ([TcTyVar], ([TyBinder], Type))
-> TcM ([TcTyVar], ([TyBinder], Type)))
-> TcM ([TcTyVar], ([TyBinder], Type))
-> TcM ([TcTyVar], ([TyBinder], Type))
forall a b. (a -> b) -> a -> b
$
TcM ([TcTyVar], ([TyBinder], Type))
-> TcM ([TcTyVar], ([TyBinder], Type))
forall a. TcM a -> TcM a
solveEqualities (TcM ([TcTyVar], ([TyBinder], Type))
-> TcM ([TcTyVar], ([TyBinder], Type)))
-> TcM ([TcTyVar], ([TyBinder], Type))
-> TcM ([TcTyVar], ([TyBinder], Type))
forall a b. (a -> b) -> a -> b
$
[Name]
-> TcM ([TyBinder], Type) -> TcM ([TcTyVar], ([TyBinder], Type))
forall a. [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Tv [Name]
XHsQTvs GhcRn
implicit_nms (TcM ([TyBinder], Type) -> TcM ([TcTyVar], ([TyBinder], Type)))
-> TcM ([TyBinder], Type) -> TcM ([TcTyVar], ([TyBinder], Type))
forall a b. (a -> b) -> a -> b
$
[(Name, TcTyVar)]
-> TcM ([TyBinder], Type) -> TcM ([TyBinder], Type)
forall r. [(Name, TcTyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, TcTyVar)]
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 (HsType GhcRn) -> Type -> Type -> TcM Coercion
unifyKind Maybe (HsType GhcRn)
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) }
; [TcTyVar]
implicit_tvs <- (TcTyVar -> TcM TcTyVar) -> [TcTyVar] -> TcM [TcTyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => TcTyVar -> TcM TcTyVar
TcTyVar -> TcM TcTyVar
zonkTcTyVarToTyVar [TcTyVar]
implicit_tvs
; [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
; let tcbs :: [TyConBinder]
tcbs = [TyConBinder]
vis_tcbs [TyConBinder] -> [TyConBinder] -> [TyConBinder]
forall a. [a] -> [a] -> [a]
++ [TyConBinder]
invis_tcbs
implicit_tv_prs :: [(Name, TcTyVar)]
implicit_tv_prs = [Name]
XHsQTvs GhcRn
implicit_nms [Name] -> [TcTyVar] -> [(Name, TcTyVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcTyVar]
implicit_tvs
all_tv_prs :: [(Name, TcTyVar)]
all_tv_prs = [(Name, TcTyVar)]
implicit_tv_prs [(Name, TcTyVar)] -> [(Name, TcTyVar)] -> [(Name, TcTyVar)]
forall a. [a] -> [a] -> [a]
++ [(Name, TcTyVar)]
explicit_tv_prs
tc :: TyCon
tc = Name
-> [TyConBinder]
-> Type
-> [(Name, TcTyVar)]
-> Bool
-> TyConFlavour
-> TyCon
mkTcTyCon Name
name [TyConBinder]
tcbs Type
r_ki [(Name, TcTyVar)]
all_tv_prs Bool
True TyConFlavour
flav
; String -> MsgDoc -> TcM ()
traceTc String
"kcCheckDeclHeader_sig done:" (MsgDoc -> TcM ()) -> MsgDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
vcat
[ String -> MsgDoc
text String
"tyConName = " MsgDoc -> MsgDoc -> MsgDoc
<+> Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (TyCon -> Name
tyConName TyCon
tc)
, String -> MsgDoc
text String
"kisig =" MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
debugPprType Type
kisig
, String -> MsgDoc
text String
"tyConKind =" MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
debugPprType (TyCon -> Type
tyConKind TyCon
tc)
, String -> MsgDoc
text String
"tyConBinders = " MsgDoc -> MsgDoc -> MsgDoc
<+> [TyConBinder] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (TyCon -> [TyConBinder]
tyConBinders TyCon
tc)
, String -> MsgDoc
text String
"tcTyConScopedTyVars" MsgDoc -> MsgDoc -> MsgDoc
<+> [(Name, TcTyVar)] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (TyCon -> [(Name, TcTyVar)]
tcTyConScopedTyVars TyCon
tc)
, String -> MsgDoc
text String
"tyConResKind" MsgDoc -> MsgDoc -> MsgDoc
<+> Type -> MsgDoc
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, TcTyVar)])
zipped_to_tcb ZippedBinder
zb = case ZippedBinder
zb of
ZippedBinder (Named (Bndr TcTyVar
v ArgFlag
Specified)) Maybe (LHsTyVarBndr GhcRn)
Nothing ->
(TyConBinder, [(Name, TcTyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TcTyVar)])
forall (m :: * -> *) a. Monad m => a -> m a
return (ArgFlag -> TcTyVar -> TyConBinder
mkNamedTyConBinder ArgFlag
Specified TcTyVar
v, [])
ZippedBinder (Named (Bndr TcTyVar
v ArgFlag
Inferred)) Maybe (LHsTyVarBndr GhcRn)
Nothing ->
(TyConBinder, [(Name, TcTyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TcTyVar)])
forall (m :: * -> *) a. Monad m => a -> m a
return (ArgFlag -> TcTyVar -> TyConBinder
mkNamedTyConBinder ArgFlag
Inferred TcTyVar
v, [])
ZippedBinder (Anon AnonArgFlag
InvisArg Type
bndr_ki) Maybe (LHsTyVarBndr GhcRn)
Nothing -> do
Name
name <- OccName -> TcRnIf TcGblEnv TcLclEnv Name
forall gbl lcl. OccName -> TcRnIf gbl lcl Name
newSysName (FastString -> OccName
mkTyVarOccFS (String -> FastString
fsLit String
"ev"))
let tv :: TcTyVar
tv = Name -> Type -> TcTyVar
mkTyVar Name
name Type
bndr_ki
(TyConBinder, [(Name, TcTyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TcTyVar)])
forall (m :: * -> *) a. Monad m => a -> m a
return (AnonArgFlag -> TcTyVar -> TyConBinder
mkAnonTyConBinder AnonArgFlag
InvisArg TcTyVar
tv, [])
ZippedBinder (Anon AnonArgFlag
VisArg Type
bndr_ki) (Just LHsTyVarBndr GhcRn
b) ->
(TyConBinder, [(Name, TcTyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TcTyVar)])
forall (m :: * -> *) a. Monad m => a -> m a
return ((TyConBinder, [(Name, TcTyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TcTyVar)]))
-> (TyConBinder, [(Name, TcTyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TcTyVar)])
forall a b. (a -> b) -> a -> b
$
let v_name :: Name
v_name = LHsTyVarBndr GhcRn -> Name
forall a. NamedThing a => a -> Name
getName LHsTyVarBndr GhcRn
b
tv :: TcTyVar
tv = Name -> Type -> TcTyVar
mkTyVar Name
v_name Type
bndr_ki
tcb :: TyConBinder
tcb = AnonArgFlag -> TcTyVar -> TyConBinder
mkAnonTyConBinder AnonArgFlag
VisArg TcTyVar
tv
in (TyConBinder
tcb, [(Name
v_name, TcTyVar
tv)])
ZippedBinder (Named (Bndr TcTyVar
v ArgFlag
Required)) (Just LHsTyVarBndr GhcRn
b) ->
(TyConBinder, [(Name, TcTyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TcTyVar)])
forall (m :: * -> *) a. Monad m => a -> m a
return ((TyConBinder, [(Name, TcTyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TcTyVar)]))
-> (TyConBinder, [(Name, TcTyVar)])
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TcTyVar)])
forall a b. (a -> b) -> a -> b
$
let v_name :: Name
v_name = LHsTyVarBndr GhcRn -> Name
forall a. NamedThing a => a -> Name
getName LHsTyVarBndr GhcRn
b
tcb :: TyConBinder
tcb = ArgFlag -> TcTyVar -> TyConBinder
mkNamedTyConBinder ArgFlag
Required TcTyVar
v
in (TyConBinder
tcb, [(Name
v_name, TcTyVar
v)])
ZippedBinder
_ -> String
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TcTyVar)])
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, TcTyVar)]
stv) <- ZippedBinder
-> IOEnv (Env TcGblEnv TcLclEnv) (TyConBinder, [(Name, TcTyVar)])
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 LHsTyVarBndr GhcRn -> SrcSpanLess (LHsTyVarBndr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsTyVarBndr GhcRn
b of
UserTyVar _ _ -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
KindedTyVar _ v v_hs_ki -> do
Type
v_ki <- UserTypeCtxt -> LHsType GhcRn -> TcM Type
tcLHsKindSig (Name -> UserTypeCtxt
TyVarBndrKindCtxt (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
GenLocated SrcSpan (IdP 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 (HsType GhcRn) -> Type -> Type -> TcM Coercion
unifyKind (HsType GhcRn -> Maybe (HsType GhcRn)
forall a. a -> Maybe a
Just (XTyVar GhcRn
-> PromotionFlag -> GenLocated SrcSpan (IdP GhcRn) -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar XTyVar GhcRn
NoExtField
noExtField PromotionFlag
NotPromoted GenLocated SrcSpan (IdP GhcRn)
v))
(TyBinder -> Type
tyBinderType TyBinder
tb)
Type
v_ki
XTyVarBndr nec -> NoExtCon -> TcM ()
forall a. NoExtCon -> a
noExtCon XXTyVarBndr GhcRn
NoExtCon
nec
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)
splitPiTysInvisible Type
sig_ki
split_invis Type
sig_ki (Just Type
res_ki) =
let n_res_invis_bndrs :: Int
n_res_invis_bndrs = Type -> Int
invisibleTyBndrCount Type
res_ki
n_sig_invis_bndrs :: Int
n_sig_invis_bndrs = Type -> Int
invisibleTyBndrCount Type
sig_ki
n_inst :: Int
n_inst = Int
n_sig_invis_bndrs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_res_invis_bndrs
in Int -> Type -> ([TyBinder], Type)
splitPiTysInvisibleN Int
n_inst Type
sig_ki
kcCheckDeclHeader_sig Type
_ Name
_ TyConFlavour
_ (XLHsQTyVars XXLHsQTyVars GhcRn
nec) TcM ContextKind
_ = NoExtCon -> TcM TyCon
forall a. NoExtCon -> a
noExtCon XXLHsQTyVars GhcRn
NoExtCon
nec
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]
-> Type
-> [LHsTyVarBndr GhcRn]
-> ([ZippedBinder], [LHsTyVarBndr GhcRn], Type)
zip_binders []
where
zip_binders :: [ZippedBinder]
-> Type
-> [LHsTyVarBndr GhcRn]
-> ([ZippedBinder], [LHsTyVarBndr GhcRn], Type)
zip_binders [ZippedBinder]
acc Type
ki [] = ([ZippedBinder] -> [ZippedBinder]
forall a. [a] -> [a]
reverse [ZippedBinder]
acc, [], Type
ki)
zip_binders [ZippedBinder]
acc Type
ki (LHsTyVarBndr GhcRn
b:[LHsTyVarBndr GhcRn]
bs) =
case Type -> Maybe (TyBinder, Type)
tcSplitPiTy_maybe Type
ki of
Maybe (TyBinder, Type)
Nothing -> ([ZippedBinder] -> [ZippedBinder]
forall a. [a] -> [a]
reverse [ZippedBinder]
acc, LHsTyVarBndr GhcRn
bLHsTyVarBndr GhcRn -> [LHsTyVarBndr GhcRn] -> [LHsTyVarBndr GhcRn]
forall a. a -> [a] -> [a]
:[LHsTyVarBndr GhcRn]
bs, Type
ki)
Just (TyBinder
tb, Type
ki') ->
let
(ZippedBinder
zb, [LHsTyVarBndr GhcRn]
bs') | Bool
zippable = (TyBinder -> Maybe (LHsTyVarBndr GhcRn) -> ZippedBinder
ZippedBinder TyBinder
tb (LHsTyVarBndr GhcRn -> Maybe (LHsTyVarBndr GhcRn)
forall a. a -> Maybe a
Just LHsTyVarBndr GhcRn
b), [LHsTyVarBndr GhcRn]
bs)
| Bool
otherwise = (TyBinder -> Maybe (LHsTyVarBndr GhcRn) -> ZippedBinder
ZippedBinder TyBinder
tb Maybe (LHsTyVarBndr GhcRn)
forall a. Maybe a
Nothing, LHsTyVarBndr GhcRn
bLHsTyVarBndr GhcRn -> [LHsTyVarBndr GhcRn] -> [LHsTyVarBndr GhcRn]
forall a. a -> [a] -> [a]
:[LHsTyVarBndr GhcRn]
bs)
zippable :: Bool
zippable =
case TyBinder
tb of
Named (Bndr TcTyVar
_ ArgFlag
Specified) -> Bool
False
Named (Bndr TcTyVar
_ ArgFlag
Inferred) -> Bool
False
Named (Bndr TcTyVar
_ ArgFlag
Required) -> Bool
True
Anon AnonArgFlag
InvisArg Type
_ -> Bool
False
Anon AnonArgFlag
VisArg Type
_ -> Bool
True
in
[ZippedBinder]
-> Type
-> [LHsTyVarBndr GhcRn]
-> ([ZippedBinder], [LHsTyVarBndr GhcRn], Type)
zip_binders (ZippedBinder
zbZippedBinder -> [ZippedBinder] -> [ZippedBinder]
forall a. a -> [a] -> [a]
:[ZippedBinder]
acc) Type
ki' [LHsTyVarBndr GhcRn]
bs'
tooManyBindersErr :: Kind -> [LHsTyVarBndr GhcRn] -> SDoc
tooManyBindersErr :: Type -> [LHsTyVarBndr GhcRn] -> MsgDoc
tooManyBindersErr Type
ki [LHsTyVarBndr GhcRn]
bndrs =
MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Not a function kind:")
Int
4 (Type -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Type
ki) MsgDoc -> MsgDoc -> MsgDoc
$$
MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"but extra binders found:")
Int
4 ([MsgDoc] -> MsgDoc
fsep ((LHsTyVarBndr GhcRn -> MsgDoc) -> [LHsTyVarBndr GhcRn] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [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 UserTypeCtxt
ThBrackCtxt = ContextKind
AnyKind
expectedKindInCtxt (GhciCtxt {}) = ContextKind
AnyKind
expectedKindInCtxt UserTypeCtxt
DefaultDeclCtxt = 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
bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,
bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv
:: [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Q_Skol :: [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Q_Skol = (Name -> TcM TcTyVar) -> [Name] -> TcM a -> TcM ([TcTyVar], a)
forall a.
(Name -> TcM TcTyVar) -> [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrsX ((Name -> TcM TcTyVar) -> Name -> TcM TcTyVar
newImplicitTyVarQ Name -> TcM TcTyVar
newFlexiKindedSkolemTyVar)
bindImplicitTKBndrs_Q_Tv :: [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Q_Tv = (Name -> TcM TcTyVar) -> [Name] -> TcM a -> TcM ([TcTyVar], a)
forall a.
(Name -> TcM TcTyVar) -> [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrsX ((Name -> TcM TcTyVar) -> Name -> TcM TcTyVar
newImplicitTyVarQ Name -> TcM TcTyVar
newFlexiKindedTyVarTyVar)
bindImplicitTKBndrs_Skol :: [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Skol = (Name -> TcM TcTyVar) -> [Name] -> TcM a -> TcM ([TcTyVar], a)
forall a.
(Name -> TcM TcTyVar) -> [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrsX Name -> TcM TcTyVar
newFlexiKindedSkolemTyVar
bindImplicitTKBndrs_Tv :: [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrs_Tv = (Name -> TcM TcTyVar) -> [Name] -> TcM a -> TcM ([TcTyVar], a)
forall a.
(Name -> TcM TcTyVar) -> [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrsX Name -> TcM TcTyVar
cloneFlexiKindedTyVarTyVar
bindImplicitTKBndrsX
:: (Name -> TcM TcTyVar)
-> [Name]
-> TcM a
-> TcM ([TcTyVar], a)
bindImplicitTKBndrsX :: (Name -> TcM TcTyVar) -> [Name] -> TcM a -> TcM ([TcTyVar], a)
bindImplicitTKBndrsX Name -> TcM TcTyVar
new_tv [Name]
tv_names TcM a
thing_inside
= do { [TcTyVar]
tkvs <- (Name -> TcM TcTyVar) -> [Name] -> TcM [TcTyVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> TcM TcTyVar
new_tv [Name]
tv_names
; String -> MsgDoc -> TcM ()
traceTc String
"bindImplicitTKBndrs" ([Name] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Name]
tv_names MsgDoc -> MsgDoc -> MsgDoc
$$ [TcTyVar] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [TcTyVar]
tkvs)
; a
res <- [(Name, TcTyVar)] -> TcM a -> TcM a
forall r. [(Name, TcTyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv ([Name]
tv_names [Name] -> [TcTyVar] -> [(Name, TcTyVar)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [TcTyVar]
tkvs)
TcM a
thing_inside
; ([TcTyVar], a) -> TcM ([TcTyVar], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([TcTyVar]
tkvs, a
res) }
newImplicitTyVarQ :: (Name -> TcM TcTyVar) -> Name -> TcM TcTyVar
newImplicitTyVarQ :: (Name -> TcM TcTyVar) -> Name -> TcM TcTyVar
newImplicitTyVarQ Name -> TcM TcTyVar
new_tv Name
name
= do { Maybe TcTyThing
mb_tv <- Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe Name
name
; case Maybe TcTyThing
mb_tv of
Just (ATyVar Name
_ TcTyVar
tv) -> TcTyVar -> TcM TcTyVar
forall (m :: * -> *) a. Monad m => a -> m a
return TcTyVar
tv
Maybe TcTyThing
_ -> Name -> TcM TcTyVar
new_tv Name
name }
newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar
newFlexiKindedTyVar :: (Name -> Type -> TcM TcTyVar) -> Name -> TcM TcTyVar
newFlexiKindedTyVar Name -> Type -> TcM TcTyVar
new_tv Name
name
= do { Type
kind <- TcM Type
newMetaKindVar
; Name -> Type -> TcM TcTyVar
new_tv Name
name Type
kind }
newFlexiKindedSkolemTyVar :: Name -> TcM TyVar
newFlexiKindedSkolemTyVar :: Name -> TcM TcTyVar
newFlexiKindedSkolemTyVar = (Name -> Type -> TcM TcTyVar) -> Name -> TcM TcTyVar
newFlexiKindedTyVar Name -> Type -> TcM TcTyVar
newSkolemTyVar
newFlexiKindedTyVarTyVar :: Name -> TcM TyVar
newFlexiKindedTyVarTyVar :: Name -> TcM TcTyVar
newFlexiKindedTyVarTyVar = (Name -> Type -> TcM TcTyVar) -> Name -> TcM TcTyVar
newFlexiKindedTyVar Name -> Type -> TcM TcTyVar
newTyVarTyVar
cloneFlexiKindedTyVarTyVar :: Name -> TcM TyVar
cloneFlexiKindedTyVarTyVar :: Name -> TcM TcTyVar
cloneFlexiKindedTyVarTyVar = (Name -> Type -> TcM TcTyVar) -> Name -> TcM TcTyVar
newFlexiKindedTyVar Name -> Type -> TcM TcTyVar
cloneTyVarTyVar
bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv
:: [LHsTyVarBndr GhcRn]
-> TcM a
-> TcM ([TcTyVar], a)
bindExplicitTKBndrs_Skol :: [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
bindExplicitTKBndrs_Skol = (HsTyVarBndr GhcRn -> TcM TcTyVar)
-> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
forall a.
(HsTyVarBndr GhcRn -> TcM TcTyVar)
-> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
bindExplicitTKBndrsX ((Name -> Type -> TcM TcTyVar) -> HsTyVarBndr GhcRn -> TcM TcTyVar
tcHsTyVarBndr Name -> Type -> TcM TcTyVar
newSkolemTyVar)
bindExplicitTKBndrs_Tv :: [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
bindExplicitTKBndrs_Tv = (HsTyVarBndr GhcRn -> TcM TcTyVar)
-> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
forall a.
(HsTyVarBndr GhcRn -> TcM TcTyVar)
-> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
bindExplicitTKBndrsX ((Name -> Type -> TcM TcTyVar) -> HsTyVarBndr GhcRn -> TcM TcTyVar
tcHsTyVarBndr Name -> Type -> TcM TcTyVar
cloneTyVarTyVar)
bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv
:: ContextKind
-> [LHsTyVarBndr GhcRn]
-> TcM a
-> TcM ([TcTyVar], a)
bindExplicitTKBndrs_Q_Skol :: ContextKind -> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
bindExplicitTKBndrs_Q_Skol ContextKind
ctxt_kind = (HsTyVarBndr GhcRn -> TcM TcTyVar)
-> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
forall a.
(HsTyVarBndr GhcRn -> TcM TcTyVar)
-> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
bindExplicitTKBndrsX (ContextKind
-> (Name -> Type -> TcM TcTyVar)
-> HsTyVarBndr GhcRn
-> TcM TcTyVar
tcHsQTyVarBndr ContextKind
ctxt_kind Name -> Type -> TcM TcTyVar
newSkolemTyVar)
bindExplicitTKBndrs_Q_Tv :: ContextKind -> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
bindExplicitTKBndrs_Q_Tv ContextKind
ctxt_kind = (HsTyVarBndr GhcRn -> TcM TcTyVar)
-> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
forall a.
(HsTyVarBndr GhcRn -> TcM TcTyVar)
-> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
bindExplicitTKBndrsX (ContextKind
-> (Name -> Type -> TcM TcTyVar)
-> HsTyVarBndr GhcRn
-> TcM TcTyVar
tcHsQTyVarBndr ContextKind
ctxt_kind Name -> Type -> TcM TcTyVar
newTyVarTyVar)
bindExplicitTKBndrsX
:: (HsTyVarBndr GhcRn -> TcM TcTyVar)
-> [LHsTyVarBndr GhcRn]
-> TcM a
-> TcM ([TcTyVar], a)
bindExplicitTKBndrsX :: (HsTyVarBndr GhcRn -> TcM TcTyVar)
-> [LHsTyVarBndr GhcRn] -> TcM a -> TcM ([TcTyVar], a)
bindExplicitTKBndrsX HsTyVarBndr GhcRn -> TcM TcTyVar
tc_tv [LHsTyVarBndr GhcRn]
hs_tvs TcM a
thing_inside
= do { String -> MsgDoc -> TcM ()
traceTc String
"bindExplicTKBndrs" ([LHsTyVarBndr GhcRn] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [LHsTyVarBndr GhcRn]
hs_tvs)
; [LHsTyVarBndr GhcRn] -> TcM ([TcTyVar], a)
go [LHsTyVarBndr GhcRn]
hs_tvs }
where
go :: [LHsTyVarBndr GhcRn] -> TcM ([TcTyVar], a)
go [] = do { a
res <- TcM a
thing_inside
; ([TcTyVar], a) -> TcM ([TcTyVar], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], a
res) }
go (L SrcSpan
_ HsTyVarBndr GhcRn
hs_tv : [LHsTyVarBndr GhcRn]
hs_tvs)
= do { TcTyVar
tv <- HsTyVarBndr GhcRn -> TcM TcTyVar
tc_tv HsTyVarBndr GhcRn
hs_tv
; ([TcTyVar]
tvs,a
res) <- [(Name, TcTyVar)] -> TcM ([TcTyVar], a) -> TcM ([TcTyVar], a)
forall r. [(Name, TcTyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(HsTyVarBndr GhcRn -> IdP GhcRn
forall (p :: Pass). HsTyVarBndr (GhcPass p) -> IdP (GhcPass p)
hsTyVarName HsTyVarBndr GhcRn
hs_tv, TcTyVar
tv)] (TcM ([TcTyVar], a) -> TcM ([TcTyVar], a))
-> TcM ([TcTyVar], a) -> TcM ([TcTyVar], a)
forall a b. (a -> b) -> a -> b
$
[LHsTyVarBndr GhcRn] -> TcM ([TcTyVar], a)
go [LHsTyVarBndr GhcRn]
hs_tvs
; ([TcTyVar], a) -> TcM ([TcTyVar], a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcTyVar
tvTcTyVar -> [TcTyVar] -> [TcTyVar]
forall a. a -> [a] -> [a]
:[TcTyVar]
tvs, a
res) }
tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar)
-> HsTyVarBndr GhcRn -> TcM TcTyVar
tcHsTyVarBndr :: (Name -> Type -> TcM TcTyVar) -> HsTyVarBndr GhcRn -> TcM TcTyVar
tcHsTyVarBndr Name -> Type -> TcM TcTyVar
new_tv (UserTyVar XUserTyVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
tv_nm))
= do { Type
kind <- TcM Type
newMetaKindVar
; Name -> Type -> TcM TcTyVar
new_tv Name
IdP GhcRn
tv_nm Type
kind }
tcHsTyVarBndr Name -> Type -> TcM TcTyVar
new_tv (KindedTyVar XKindedTyVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
tv_nm) LHsType GhcRn
lhs_kind)
= do { Type
kind <- UserTypeCtxt -> LHsType GhcRn -> TcM Type
tcLHsKindSig (Name -> UserTypeCtxt
TyVarBndrKindCtxt Name
IdP GhcRn
tv_nm) LHsType GhcRn
lhs_kind
; Name -> Type -> TcM TcTyVar
new_tv Name
IdP GhcRn
tv_nm Type
kind }
tcHsTyVarBndr Name -> Type -> TcM TcTyVar
_ (XTyVarBndr XXTyVarBndr GhcRn
nec) = NoExtCon -> TcM TcTyVar
forall a. NoExtCon -> a
noExtCon XXTyVarBndr GhcRn
NoExtCon
nec
tcHsQTyVarBndr :: ContextKind
-> (Name -> Kind -> TcM TyVar)
-> HsTyVarBndr GhcRn -> TcM TcTyVar
tcHsQTyVarBndr :: ContextKind
-> (Name -> Type -> TcM TcTyVar)
-> HsTyVarBndr GhcRn
-> TcM TcTyVar
tcHsQTyVarBndr ContextKind
ctxt_kind Name -> Type -> TcM TcTyVar
new_tv (UserTyVar XUserTyVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
tv_nm))
= do { Maybe TcTyThing
mb_tv <- Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe Name
IdP GhcRn
tv_nm
; case Maybe TcTyThing
mb_tv of
Just (ATyVar Name
_ TcTyVar
tv) -> TcTyVar -> TcM TcTyVar
forall (m :: * -> *) a. Monad m => a -> m a
return TcTyVar
tv
Maybe TcTyThing
_ -> do { Type
kind <- ContextKind -> TcM Type
newExpectedKind ContextKind
ctxt_kind
; Name -> Type -> TcM TcTyVar
new_tv Name
IdP GhcRn
tv_nm Type
kind } }
tcHsQTyVarBndr ContextKind
_ Name -> Type -> TcM TcTyVar
new_tv (KindedTyVar XKindedTyVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
tv_nm) LHsType GhcRn
lhs_kind)
= do { Type
kind <- UserTypeCtxt -> LHsType GhcRn -> TcM Type
tcLHsKindSig (Name -> UserTypeCtxt
TyVarBndrKindCtxt Name
IdP GhcRn
tv_nm) LHsType GhcRn
lhs_kind
; Maybe TcTyThing