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