{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.Utils.TcMType (
TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet,
newFlexiTyVar,
newNamedFlexiTyVar,
newFlexiTyVarTy,
newFlexiTyVarTys,
newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind,
newOpenBoxedTypeKind,
newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel,
newAnonMetaTyVar, cloneMetaTyVar,
newCycleBreakerTyVar,
newMultiplicityVar,
readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
newTauTvDetailsAtLevel, newMetaDetails, newMetaTyVarName,
isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar,
newEvVar, newEvVars, newDict,
newWanted, newWanteds, cloneWanted, cloneWC,
emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,
emitDerivedEqs,
newTcEvBinds, newNoTcEvBinds, addTcEvBind,
emitNewExprHole,
newCoercionHole, fillCoercionHole, isFilledCoercionHole,
unpackCoercionHole, unpackCoercionHole_maybe,
checkCoercionHole,
newImplication,
newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,
newMetaTyVarTyVarX,
newTyVarTyVar, cloneTyVarTyVar,
newPatSigTyVar, newSkolemTyVar, newWildCardX,
ExpType(..), ExpSigmaType, ExpRhoType,
mkCheckExpType, newInferExpType, tcInfer,
readExpType, readExpType_maybe, readScaledExpType,
expTypeToType, scaledExpTypeToType,
checkingExpType_maybe, checkingExpType,
inferResultToType, fillInferResult, promoteTcType,
zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin,
tidyEvVar, tidyCt, tidyHole, tidySkolemInfo,
zonkTcTyVar, zonkTcTyVars,
zonkTcTyVarToTyVar, zonkInvisTVBinder,
zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV,
zonkTyCoVarsAndFVList,
zonkTcType, zonkTcTypes, zonkCo,
zonkTyCoVarKind, zonkTyCoVarKindBinder,
zonkEvVar, zonkWC, zonkImplication, zonkSimples,
zonkId, zonkCoVar,
zonkCt, zonkSkolemInfo,
defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet,
quantifyTyVars, isQuantifiableTv,
skolemiseUnboundMetaTyVar, zonkAndSkolemise, skolemiseQuantifiedTyVar,
doNotQuantifyTyVars,
candidateQTyVarsOfType, candidateQTyVarsOfKind,
candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,
CandidatesQTvs(..), delCandidates,
candidateKindVars, partitionCandidates,
ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr
) where
#include "HsVersions.h"
import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType )
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr
import GHC.Tc.Utils.TcType
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.Coercion
import GHC.Core.Class
import GHC.Types.Var
import GHC.Core.Predicate
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Evidence
import GHC.Types.Id as Id
import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Builtin.Types
import GHC.Types.Var.Env
import GHC.Types.Name.Env
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Data.Bag
import GHC.Data.Pair
import GHC.Types.Unique.Set
import GHC.Driver.Session
import GHC.Driver.Ppr
import qualified GHC.LanguageExtensions as LangExt
import GHC.Types.Basic ( TypeOrKind(..) )
import Control.Monad
import GHC.Data.Maybe
import qualified Data.Semigroup as Semi
newMetaKindVar :: TcM TcKind
newMetaKindVar :: TcM Kind
newMetaKindVar
= do { TcTyVarDetails
details <- MetaInfo -> TcM TcTyVarDetails
newMetaDetails MetaInfo
TauTv
; Name
name <- FastString -> TcM Name
newMetaTyVarName (String -> FastString
fsLit String
"k")
; let kv :: TyVar
kv = Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar Name
name Kind
liftedTypeKind TcTyVarDetails
details
; String -> SDoc -> TcRn ()
traceTc String
"newMetaKindVar" (forall a. Outputable a => a -> SDoc
ppr TyVar
kv)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Kind
mkTyVarTy TyVar
kv) }
newMetaKindVars :: Int -> TcM [TcKind]
newMetaKindVars :: Int -> TcM [Kind]
newMetaKindVars Int
n = forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n TcM Kind
newMetaKindVar
newEvVars :: TcThetaType -> TcM [EvVar]
newEvVars :: [Kind] -> TcM [TyVar]
newEvVars [Kind]
theta = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall gbl lcl. Kind -> TcRnIf gbl lcl TyVar
newEvVar [Kind]
theta
newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar
newEvVar :: forall gbl lcl. Kind -> TcRnIf gbl lcl TyVar
newEvVar Kind
ty = do { Name
name <- forall gbl lcl. OccName -> TcRnIf gbl lcl Name
newSysName (Kind -> OccName
predTypeOccName Kind
ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Kind -> Kind -> TyVar
mkLocalIdOrCoVar Name
name Kind
Many Kind
ty) }
newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence
newWanted :: CtOrigin -> Maybe TypeOrKind -> Kind -> TcM CtEvidence
newWanted CtOrigin
orig Maybe TypeOrKind
t_or_k Kind
pty
= do CtLoc
loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
orig Maybe TypeOrKind
t_or_k
TcEvDest
d <- if Kind -> Bool
isEqPrimPred Kind
pty then CoercionHole -> TcEvDest
HoleDest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> TcM CoercionHole
newCoercionHole Kind
pty
else TyVar -> TcEvDest
EvVarDest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall gbl lcl. Kind -> TcRnIf gbl lcl TyVar
newEvVar Kind
pty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CtWanted { ctev_dest :: TcEvDest
ctev_dest = TcEvDest
d
, ctev_pred :: Kind
ctev_pred = Kind
pty
, ctev_nosh :: ShadowInfo
ctev_nosh = ShadowInfo
WDeriv
, ctev_loc :: CtLoc
ctev_loc = CtLoc
loc }
newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence]
newWanteds :: CtOrigin -> [Kind] -> TcM [CtEvidence]
newWanteds CtOrigin
orig = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CtOrigin -> Maybe TypeOrKind -> Kind -> TcM CtEvidence
newWanted CtOrigin
orig forall a. Maybe a
Nothing)
cloneWanted :: Ct -> TcM Ct
cloneWanted :: Ct -> TcM Ct
cloneWanted Ct
ct
| ev :: CtEvidence
ev@(CtWanted { ctev_pred :: CtEvidence -> Kind
ctev_pred = Kind
pty, ctev_dest :: CtEvidence -> TcEvDest
ctev_dest = HoleDest CoercionHole
_ }) <- Ct -> CtEvidence
ctEvidence Ct
ct
= do { CoercionHole
co_hole <- Kind -> TcM CoercionHole
newCoercionHole Kind
pty
; forall (m :: * -> *) a. Monad m => a -> m a
return (CtEvidence -> Ct
mkNonCanonical (CtEvidence
ev { ctev_dest :: TcEvDest
ctev_dest = CoercionHole -> TcEvDest
HoleDest CoercionHole
co_hole })) }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return Ct
ct
cloneWC :: WantedConstraints -> TcM WantedConstraints
cloneWC :: WantedConstraints -> TcM WantedConstraints
cloneWC wc :: WantedConstraints
wc@(WC { wc_simple :: WantedConstraints -> Bag Ct
wc_simple = Bag Ct
simples, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
implics })
= do { Bag Ct
simples' <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM Ct -> TcM Ct
cloneWanted Bag Ct
simples
; Bag Implication
implics' <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM Implication -> TcM Implication
cloneImplication Bag Implication
implics
; forall (m :: * -> *) a. Monad m => a -> m a
return (WantedConstraints
wc { wc_simple :: Bag Ct
wc_simple = Bag Ct
simples', wc_impl :: Bag Implication
wc_impl = Bag Implication
implics' }) }
cloneImplication :: Implication -> TcM Implication
cloneImplication :: Implication -> TcM Implication
cloneImplication implic :: Implication
implic@(Implic { ic_binds :: Implication -> EvBindsVar
ic_binds = EvBindsVar
binds, ic_wanted :: Implication -> WantedConstraints
ic_wanted = WantedConstraints
inner_wanted })
= do { EvBindsVar
binds' <- EvBindsVar -> TcM EvBindsVar
cloneEvBindsVar EvBindsVar
binds
; WantedConstraints
inner_wanted' <- WantedConstraints -> TcM WantedConstraints
cloneWC WantedConstraints
inner_wanted
; forall (m :: * -> *) a. Monad m => a -> m a
return (Implication
implic { ic_binds :: EvBindsVar
ic_binds = EvBindsVar
binds', ic_wanted :: WantedConstraints
ic_wanted = WantedConstraints
inner_wanted' }) }
emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm
emitWanted :: CtOrigin -> Kind -> TcM EvTerm
emitWanted CtOrigin
origin Kind
pty
= do { CtEvidence
ev <- CtOrigin -> Maybe TypeOrKind -> Kind -> TcM CtEvidence
newWanted CtOrigin
origin forall a. Maybe a
Nothing Kind
pty
; Ct -> TcRn ()
emitSimple forall a b. (a -> b) -> a -> b
$ CtEvidence -> Ct
mkNonCanonical CtEvidence
ev
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CtEvidence -> EvTerm
ctEvTerm CtEvidence
ev }
emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()
emitDerivedEqs :: CtOrigin -> [(Kind, Kind)] -> TcRn ()
emitDerivedEqs CtOrigin
origin [(Kind, Kind)]
pairs
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Kind, Kind)]
pairs
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= do { CtLoc
loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
origin forall a. Maybe a
Nothing
; Bag Ct -> TcRn ()
emitSimples (forall a. [a] -> Bag a
listToBag (forall a b. (a -> b) -> [a] -> [b]
map (CtLoc -> (Kind, Kind) -> Ct
mk_one CtLoc
loc) [(Kind, Kind)]
pairs)) }
where
mk_one :: CtLoc -> (Kind, Kind) -> Ct
mk_one CtLoc
loc (Kind
ty1, Kind
ty2)
= CtEvidence -> Ct
mkNonCanonical forall a b. (a -> b) -> a -> b
$
CtDerived { ctev_pred :: Kind
ctev_pred = Kind -> Kind -> Kind
mkPrimEqPred Kind
ty1 Kind
ty2
, ctev_loc :: CtLoc
ctev_loc = CtLoc
loc }
emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion
emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> Kind -> Kind -> TcM Coercion
emitWantedEq CtOrigin
origin TypeOrKind
t_or_k Role
role Kind
ty1 Kind
ty2
= do { CoercionHole
hole <- Kind -> TcM CoercionHole
newCoercionHole Kind
pty
; CtLoc
loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
origin (forall a. a -> Maybe a
Just TypeOrKind
t_or_k)
; Ct -> TcRn ()
emitSimple forall a b. (a -> b) -> a -> b
$ CtEvidence -> Ct
mkNonCanonical forall a b. (a -> b) -> a -> b
$
CtWanted { ctev_pred :: Kind
ctev_pred = Kind
pty, ctev_dest :: TcEvDest
ctev_dest = CoercionHole -> TcEvDest
HoleDest CoercionHole
hole
, ctev_nosh :: ShadowInfo
ctev_nosh = ShadowInfo
WDeriv, ctev_loc :: CtLoc
ctev_loc = CtLoc
loc }
; forall (m :: * -> *) a. Monad m => a -> m a
return (CoercionHole -> Coercion
HoleCo CoercionHole
hole) }
where
pty :: Kind
pty = Role -> Kind -> Kind -> Kind
mkPrimEqPredRole Role
role Kind
ty1 Kind
ty2
emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar
emitWantedEvVar :: CtOrigin -> Kind -> TcM TyVar
emitWantedEvVar CtOrigin
origin Kind
ty
= do { TyVar
new_cv <- forall gbl lcl. Kind -> TcRnIf gbl lcl TyVar
newEvVar Kind
ty
; CtLoc
loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
origin forall a. Maybe a
Nothing
; let ctev :: CtEvidence
ctev = CtWanted { ctev_dest :: TcEvDest
ctev_dest = TyVar -> TcEvDest
EvVarDest TyVar
new_cv
, ctev_pred :: Kind
ctev_pred = Kind
ty
, ctev_nosh :: ShadowInfo
ctev_nosh = ShadowInfo
WDeriv
, ctev_loc :: CtLoc
ctev_loc = CtLoc
loc }
; Ct -> TcRn ()
emitSimple forall a b. (a -> b) -> a -> b
$ CtEvidence -> Ct
mkNonCanonical CtEvidence
ctev
; forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
new_cv }
emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar]
emitWantedEvVars :: CtOrigin -> [Kind] -> TcM [TyVar]
emitWantedEvVars CtOrigin
orig = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CtOrigin -> Kind -> TcM TyVar
emitWantedEvVar CtOrigin
orig)
emitNewExprHole :: OccName
-> Type -> TcM HoleExprRef
emitNewExprHole :: OccName -> Kind -> TcM HoleExprRef
emitNewExprHole OccName
occ Kind
ty
= do { Unique
u <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; TcRef EvTerm
ref <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef (forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unfilled unbound-variable evidence" (forall a. Outputable a => a -> SDoc
ppr Unique
u))
; let her :: HoleExprRef
her = TcRef EvTerm -> Kind -> Unique -> HoleExprRef
HER TcRef EvTerm
ref Kind
ty Unique
u
; CtLoc
loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM (Maybe OccName -> CtOrigin
ExprHoleOrigin (forall a. a -> Maybe a
Just OccName
occ)) (forall a. a -> Maybe a
Just TypeOrKind
TypeLevel)
; let hole :: Hole
hole = Hole { hole_sort :: HoleSort
hole_sort = HoleExprRef -> HoleSort
ExprHole HoleExprRef
her
, hole_occ :: OccName
hole_occ = OccName
occ
, hole_ty :: Kind
hole_ty = Kind
ty
, hole_loc :: CtLoc
hole_loc = CtLoc
loc }
; Hole -> TcRn ()
emitHole Hole
hole
; forall (m :: * -> *) a. Monad m => a -> m a
return HoleExprRef
her }
newDict :: Class -> [TcType] -> TcM DictId
newDict :: Class -> [Kind] -> TcM TyVar
newDict Class
cls [Kind]
tys
= do { Name
name <- forall gbl lcl. OccName -> TcRnIf gbl lcl Name
newSysName (OccName -> OccName
mkDictOcc (forall a. NamedThing a => a -> OccName
getOccName Class
cls))
; forall (m :: * -> *) a. Monad m => a -> m a
return (HasDebugCallStack => Name -> Kind -> Kind -> TyVar
mkLocalId Name
name Kind
Many (Class -> [Kind] -> Kind
mkClassPred Class
cls [Kind]
tys)) }
predTypeOccName :: PredType -> OccName
predTypeOccName :: Kind -> OccName
predTypeOccName Kind
ty = case Kind -> Pred
classifyPredType Kind
ty of
ClassPred Class
cls [Kind]
_ -> OccName -> OccName
mkDictOcc (forall a. NamedThing a => a -> OccName
getOccName Class
cls)
EqPred {} -> FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"co")
IrredPred {} -> FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"irred")
ForAllPred {} -> FastString -> OccName
mkVarOccFS (String -> FastString
fsLit String
"df")
newImplication :: TcM Implication
newImplication :: TcM Implication
newImplication
= do TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
Bool
warn_inaccessible <- forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
Opt_WarnInaccessibleCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Implication
implicationPrototype { ic_env :: TcLclEnv
ic_env = TcLclEnv
env
, ic_warn_inaccessible :: Bool
ic_warn_inaccessible = Bool
warn_inaccessible })
newCoercionHole :: TcPredType -> TcM CoercionHole
newCoercionHole :: Kind -> TcM CoercionHole
newCoercionHole Kind
pred_ty
= do { TyVar
co_var <- forall gbl lcl. Kind -> TcRnIf gbl lcl TyVar
newEvVar Kind
pred_ty
; String -> SDoc -> TcRn ()
traceTc String
"New coercion hole:" (forall a. Outputable a => a -> SDoc
ppr TyVar
co_var)
; IORef (Maybe Coercion)
ref <- forall a env. a -> IOEnv env (IORef a)
newMutVar forall a. Maybe a
Nothing
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CoercionHole { ch_co_var :: TyVar
ch_co_var = TyVar
co_var, ch_ref :: IORef (Maybe Coercion)
ch_ref = IORef (Maybe Coercion)
ref } }
fillCoercionHole :: CoercionHole -> Coercion -> TcM ()
fillCoercionHole :: CoercionHole -> Coercion -> TcRn ()
fillCoercionHole (CoercionHole { ch_ref :: CoercionHole -> IORef (Maybe Coercion)
ch_ref = IORef (Maybe Coercion)
ref, ch_co_var :: CoercionHole -> TyVar
ch_co_var = TyVar
cv }) Coercion
co
= do {
#if defined(DEBUG)
; cts <- readTcRef ref
; whenIsJust cts $ \old_co ->
pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co)
#endif
; String -> SDoc -> TcRn ()
traceTc String
"Filling coercion hole" (forall a. Outputable a => a -> SDoc
ppr TyVar
cv SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
":=" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Coercion
co)
; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef (Maybe Coercion)
ref (forall a. a -> Maybe a
Just Coercion
co) }
isFilledCoercionHole :: CoercionHole -> TcM Bool
isFilledCoercionHole :: CoercionHole -> TcM Bool
isFilledCoercionHole (CoercionHole { ch_ref :: CoercionHole -> IORef (Maybe Coercion)
ch_ref = IORef (Maybe Coercion)
ref }) = forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Maybe Coercion)
ref
unpackCoercionHole :: CoercionHole -> TcM Coercion
unpackCoercionHole :: CoercionHole -> TcM Coercion
unpackCoercionHole CoercionHole
hole
= do { Maybe Coercion
contents <- CoercionHole -> TcM (Maybe Coercion)
unpackCoercionHole_maybe CoercionHole
hole
; case Maybe Coercion
contents of
Just Coercion
co -> forall (m :: * -> *) a. Monad m => a -> m a
return Coercion
co
Maybe Coercion
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Unfilled coercion hole" (forall a. Outputable a => a -> SDoc
ppr CoercionHole
hole) }
unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion)
unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion)
unpackCoercionHole_maybe (CoercionHole { ch_ref :: CoercionHole -> IORef (Maybe Coercion)
ch_ref = IORef (Maybe Coercion)
ref }) = forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Maybe Coercion)
ref
checkCoercionHole :: CoVar -> Coercion -> TcM Coercion
checkCoercionHole :: TyVar -> Coercion -> TcM Coercion
checkCoercionHole TyVar
cv Coercion
co
| Bool
debugIsOn
= do { Kind
cv_ty <- Kind -> TcM Kind
zonkTcType (TyVar -> Kind
varType TyVar
cv)
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
ASSERT2( ok cv_ty
, (text "Bad coercion hole" <+>
ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role
, ppr cv_ty ]) )
Coercion
co }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return Coercion
co
where
(Pair Kind
t1 Kind
t2, Role
role) = Coercion -> (Pair Kind, Role)
coercionKindRole Coercion
co
ok :: Kind -> Bool
ok Kind
cv_ty | EqPred EqRel
cv_rel Kind
cv_t1 Kind
cv_t2 <- Kind -> Pred
classifyPredType Kind
cv_ty
= Kind
t1 Kind -> Kind -> Bool
`eqType` Kind
cv_t1
Bool -> Bool -> Bool
&& Kind
t2 Kind -> Kind -> Bool
`eqType` Kind
cv_t2
Bool -> Bool -> Bool
&& Role
role forall a. Eq a => a -> a -> Bool
== EqRel -> Role
eqRelRole EqRel
cv_rel
| Bool
otherwise
= Bool
False
newInferExpType :: TcM ExpType
newInferExpType :: TcM ExpType
newInferExpType
= do { Unique
u <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; TcLevel
tclvl <- TcM TcLevel
getTcLevel
; String -> SDoc -> TcRn ()
traceTc String
"newInferExpType" (forall a. Outputable a => a -> SDoc
ppr Unique
u SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl)
; IORef (Maybe Kind)
ref <- forall a env. a -> IOEnv env (IORef a)
newMutVar forall a. Maybe a
Nothing
; forall (m :: * -> *) a. Monad m => a -> m a
return (InferResult -> ExpType
Infer (IR { ir_uniq :: Unique
ir_uniq = Unique
u, ir_lvl :: TcLevel
ir_lvl = TcLevel
tclvl
, ir_ref :: IORef (Maybe Kind)
ir_ref = IORef (Maybe Kind)
ref })) }
readExpType_maybe :: ExpType -> TcM (Maybe TcType)
readExpType_maybe :: ExpType -> TcM (Maybe Kind)
readExpType_maybe (Check Kind
ty) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Kind
ty)
readExpType_maybe (Infer (IR { ir_ref :: InferResult -> IORef (Maybe Kind)
ir_ref = IORef (Maybe Kind)
ref})) = forall a env. IORef a -> IOEnv env a
readMutVar IORef (Maybe Kind)
ref
readScaledExpType :: Scaled ExpType -> TcM (Scaled Type)
readScaledExpType :: Scaled ExpType -> TcM (Scaled Kind)
readScaledExpType (Scaled Kind
m ExpType
exp_ty)
= do { Kind
ty <- ExpType -> TcM Kind
readExpType ExpType
exp_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Kind -> a -> Scaled a
Scaled Kind
m Kind
ty) }
readExpType :: ExpType -> TcM TcType
readExpType :: ExpType -> TcM Kind
readExpType ExpType
exp_ty
= do { Maybe Kind
mb_ty <- ExpType -> TcM (Maybe Kind)
readExpType_maybe ExpType
exp_ty
; case Maybe Kind
mb_ty of
Just Kind
ty -> forall (m :: * -> *) a. Monad m => a -> m a
return Kind
ty
Maybe Kind
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Unknown expected type" (forall a. Outputable a => a -> SDoc
ppr ExpType
exp_ty) }
checkingExpType_maybe :: ExpType -> Maybe TcType
checkingExpType_maybe :: ExpType -> Maybe Kind
checkingExpType_maybe (Check Kind
ty) = forall a. a -> Maybe a
Just Kind
ty
checkingExpType_maybe (Infer {}) = forall a. Maybe a
Nothing
checkingExpType :: String -> ExpType -> TcType
checkingExpType :: String -> ExpType -> Kind
checkingExpType String
_ (Check Kind
ty) = Kind
ty
checkingExpType String
err ExpType
et = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"checkingExpType" (String -> SDoc
text String
err SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr ExpType
et)
scaledExpTypeToType :: Scaled ExpType -> TcM (Scaled TcType)
scaledExpTypeToType :: Scaled ExpType -> TcM (Scaled Kind)
scaledExpTypeToType (Scaled Kind
m ExpType
exp_ty)
= do { Kind
ty <- ExpType -> TcM Kind
expTypeToType ExpType
exp_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Kind -> a -> Scaled a
Scaled Kind
m Kind
ty) }
expTypeToType :: ExpType -> TcM TcType
expTypeToType :: ExpType -> TcM Kind
expTypeToType (Check Kind
ty) = forall (m :: * -> *) a. Monad m => a -> m a
return Kind
ty
expTypeToType (Infer InferResult
inf_res) = InferResult -> TcM Kind
inferResultToType InferResult
inf_res
inferResultToType :: InferResult -> TcM Type
inferResultToType :: InferResult -> TcM Kind
inferResultToType (IR { ir_uniq :: InferResult -> Unique
ir_uniq = Unique
u, ir_lvl :: InferResult -> TcLevel
ir_lvl = TcLevel
tc_lvl
, ir_ref :: InferResult -> IORef (Maybe Kind)
ir_ref = IORef (Maybe Kind)
ref })
= do { Maybe Kind
mb_inferred_ty <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Maybe Kind)
ref
; Kind
tau <- case Maybe Kind
mb_inferred_ty of
Just Kind
ty -> do { Kind -> TcRn ()
ensureMonoType Kind
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return Kind
ty }
Maybe Kind
Nothing -> do { Kind
rr <- TcLevel -> Kind -> TcM Kind
newMetaTyVarTyAtLevel TcLevel
tc_lvl Kind
runtimeRepTy
; Kind
tau <- TcLevel -> Kind -> TcM Kind
newMetaTyVarTyAtLevel TcLevel
tc_lvl (Kind -> Kind
tYPE Kind
rr)
; forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef (Maybe Kind)
ref (forall a. a -> Maybe a
Just Kind
tau)
; forall (m :: * -> *) a. Monad m => a -> m a
return Kind
tau }
; String -> SDoc -> TcRn ()
traceTc String
"Forcing ExpType to be monomorphic:"
(forall a. Outputable a => a -> SDoc
ppr Unique
u SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
":=" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
tau)
; forall (m :: * -> *) a. Monad m => a -> m a
return Kind
tau }
tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
tcInfer :: forall a. (ExpType -> TcM a) -> TcM (a, Kind)
tcInfer ExpType -> TcM a
tc_check
= do { ExpType
res_ty <- TcM ExpType
newInferExpType
; a
result <- ExpType -> TcM a
tc_check ExpType
res_ty
; Kind
res_ty <- ExpType -> TcM Kind
readExpType ExpType
res_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, Kind
res_ty) }
fillInferResult :: TcType -> InferResult -> TcM TcCoercionN
fillInferResult :: Kind -> InferResult -> TcM Coercion
fillInferResult Kind
act_res_ty (IR { ir_uniq :: InferResult -> Unique
ir_uniq = Unique
u, ir_lvl :: InferResult -> TcLevel
ir_lvl = TcLevel
res_lvl
, ir_ref :: InferResult -> IORef (Maybe Kind)
ir_ref = IORef (Maybe Kind)
ref })
= do { Maybe Kind
mb_exp_res_ty <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Maybe Kind)
ref
; case Maybe Kind
mb_exp_res_ty of
Just Kind
exp_res_ty
-> do { String -> SDoc -> TcRn ()
traceTc String
"Joining inferred ExpType" forall a b. (a -> b) -> a -> b
$
forall a. Outputable a => a -> SDoc
ppr Unique
u SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
act_res_ty SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'~' SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
exp_res_ty
; TcLevel
cur_lvl <- TcM TcLevel
getTcLevel
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TcLevel
cur_lvl TcLevel -> TcLevel -> Bool
`sameDepthAs` TcLevel
res_lvl) forall a b. (a -> b) -> a -> b
$
Kind -> TcRn ()
ensureMonoType Kind
act_res_ty
; Maybe SDoc -> Kind -> Kind -> TcM Coercion
unifyType forall a. Maybe a
Nothing Kind
act_res_ty Kind
exp_res_ty }
Maybe Kind
Nothing
-> do { String -> SDoc -> TcRn ()
traceTc String
"Filling inferred ExpType" forall a b. (a -> b) -> a -> b
$
forall a. Outputable a => a -> SDoc
ppr Unique
u SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
":=" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
act_res_ty
; (Coercion
prom_co, Kind
act_res_ty) <- TcLevel -> Kind -> TcM (Coercion, Kind)
promoteTcType TcLevel
res_lvl Kind
act_res_ty
; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef (Maybe Kind)
ref (forall a. a -> Maybe a
Just Kind
act_res_ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return Coercion
prom_co }
}
ensureMonoType :: TcType -> TcM ()
ensureMonoType :: Kind -> TcRn ()
ensureMonoType Kind
res_ty
| Kind -> Bool
isTauTy Kind
res_ty
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= do { Kind
mono_ty <- TcM Kind
newOpenFlexiTyVarTy
; let eq_orig :: CtOrigin
eq_orig = TypeEqOrigin { uo_actual :: Kind
uo_actual = Kind
res_ty
, uo_expected :: Kind
uo_expected = Kind
mono_ty
, uo_thing :: Maybe SDoc
uo_thing = forall a. Maybe a
Nothing
, uo_visible :: Bool
uo_visible = Bool
False }
; Coercion
_co <- CtOrigin -> TypeOrKind -> Role -> Kind -> Kind -> TcM Coercion
emitWantedEq CtOrigin
eq_orig TypeOrKind
TypeLevel Role
Nominal Kind
res_ty Kind
mono_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return () }
promoteTcType :: TcLevel -> TcType -> TcM (TcCoercionN, TcType)
promoteTcType :: TcLevel -> Kind -> TcM (Coercion, Kind)
promoteTcType TcLevel
dest_lvl Kind
ty
= do { TcLevel
cur_lvl <- TcM TcLevel
getTcLevel
; if (TcLevel
cur_lvl TcLevel -> TcLevel -> Bool
`sameDepthAs` TcLevel
dest_lvl)
then forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Coercion
mkTcNomReflCo Kind
ty, Kind
ty)
else TcM (Coercion, Kind)
promote_it }
where
promote_it :: TcM (TcCoercion, TcType)
promote_it :: TcM (Coercion, Kind)
promote_it
= do { Kind
rr <- TcLevel -> Kind -> TcM Kind
newMetaTyVarTyAtLevel TcLevel
dest_lvl Kind
runtimeRepTy
; Kind
prom_ty <- TcLevel -> Kind -> TcM Kind
newMetaTyVarTyAtLevel TcLevel
dest_lvl (Kind -> Kind
tYPE Kind
rr)
; let eq_orig :: CtOrigin
eq_orig = TypeEqOrigin { uo_actual :: Kind
uo_actual = Kind
ty
, uo_expected :: Kind
uo_expected = Kind
prom_ty
, uo_thing :: Maybe SDoc
uo_thing = forall a. Maybe a
Nothing
, uo_visible :: Bool
uo_visible = Bool
False }
; Coercion
co <- CtOrigin -> TypeOrKind -> Role -> Kind -> Kind -> TcM Coercion
emitWantedEq CtOrigin
eq_orig TypeOrKind
TypeLevel Role
Nominal Kind
ty Kind
prom_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion
co, Kind
prom_ty) }
newMetaTyVarName :: FastString -> TcM Name
newMetaTyVarName :: FastString -> TcM Name
newMetaTyVarName FastString
str
= do { Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> OccName -> Name
mkSystemName Unique
uniq (FastString -> OccName
mkTyVarOccFS FastString
str)) }
cloneMetaTyVarName :: Name -> TcM Name
cloneMetaTyVarName :: Name -> TcM Name
cloneMetaTyVarName Name
name
= do { Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> OccName -> Name
mkSystemName Unique
uniq (Name -> OccName
nameOccName Name
name)) }
metaInfoToTyVarName :: MetaInfo -> FastString
metaInfoToTyVarName :: MetaInfo -> FastString
metaInfoToTyVarName MetaInfo
meta_info =
case MetaInfo
meta_info of
MetaInfo
TauTv -> String -> FastString
fsLit String
"t"
MetaInfo
TyVarTv -> String -> FastString
fsLit String
"a"
MetaInfo
RuntimeUnkTv -> String -> FastString
fsLit String
"r"
MetaInfo
CycleBreakerTv -> String -> FastString
fsLit String
"b"
newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TyVar
newAnonMetaTyVar MetaInfo
mi = FastString -> MetaInfo -> Kind -> TcM TyVar
newNamedAnonMetaTyVar (MetaInfo -> FastString
metaInfoToTyVarName MetaInfo
mi) MetaInfo
mi
newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TcTyVar
newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TyVar
newNamedAnonMetaTyVar FastString
tyvar_name MetaInfo
meta_info Kind
kind
= do { Name
name <- FastString -> TcM Name
newMetaTyVarName FastString
tyvar_name
; TcTyVarDetails
details <- MetaInfo -> TcM TcTyVarDetails
newMetaDetails MetaInfo
meta_info
; let tyvar :: TyVar
tyvar = Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar Name
name Kind
kind TcTyVarDetails
details
; String -> SDoc -> TcRn ()
traceTc String
"newAnonMetaTyVar" (forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar)
; forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
tyvar }
newSkolemTyVar :: Name -> Kind -> TcM TcTyVar
newSkolemTyVar :: Name -> Kind -> TcM TyVar
newSkolemTyVar Name
name Kind
kind
= do { TcLevel
lvl <- TcM TcLevel
getTcLevel
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar Name
name Kind
kind (TcLevel -> Bool -> TcTyVarDetails
SkolemTv TcLevel
lvl Bool
False)) }
newTyVarTyVar :: Name -> Kind -> TcM TcTyVar
newTyVarTyVar :: Name -> Kind -> TcM TyVar
newTyVarTyVar Name
name Kind
kind
= do { TcTyVarDetails
details <- MetaInfo -> TcM TcTyVarDetails
newMetaDetails MetaInfo
TyVarTv
; let tyvar :: TyVar
tyvar = Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar Name
name Kind
kind TcTyVarDetails
details
; String -> SDoc -> TcRn ()
traceTc String
"newTyVarTyVar" (forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar)
; forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
tyvar }
cloneTyVarTyVar :: Name -> Kind -> TcM TcTyVar
cloneTyVarTyVar :: Name -> Kind -> TcM TyVar
cloneTyVarTyVar Name
name Kind
kind
= do { TcTyVarDetails
details <- MetaInfo -> TcM TcTyVarDetails
newMetaDetails MetaInfo
TyVarTv
; Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; let name' :: Name
name' = Name
name Name -> Unique -> Name
`setNameUnique` Unique
uniq
tyvar :: TyVar
tyvar = Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar Name
name' Kind
kind TcTyVarDetails
details
; String -> SDoc -> TcRn ()
traceTc String
"cloneTyVarTyVar" (forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar)
; forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
tyvar }
newPatSigTyVar :: Name -> Kind -> TcM TcTyVar
newPatSigTyVar :: Name -> Kind -> TcM TyVar
newPatSigTyVar Name
name Kind
kind
= do { TcTyVarDetails
details <- MetaInfo -> TcM TcTyVarDetails
newMetaDetails MetaInfo
TauTv
; Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; let name' :: Name
name' = Name
name Name -> Unique -> Name
`setNameUnique` Unique
uniq
tyvar :: TyVar
tyvar = Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar Name
name' Kind
kind TcTyVarDetails
details
; String -> SDoc -> TcRn ()
traceTc String
"newPatSigTyVar" (forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar)
; forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
tyvar }
cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar
cloneAnonMetaTyVar :: MetaInfo -> TyVar -> Kind -> TcM TyVar
cloneAnonMetaTyVar MetaInfo
info TyVar
tv Kind
kind
= do { TcTyVarDetails
details <- MetaInfo -> TcM TcTyVarDetails
newMetaDetails MetaInfo
info
; Name
name <- Name -> TcM Name
cloneMetaTyVarName (TyVar -> Name
tyVarName TyVar
tv)
; let tyvar :: TyVar
tyvar = Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar Name
name Kind
kind TcTyVarDetails
details
; String -> SDoc -> TcRn ()
traceTc String
"cloneAnonMetaTyVar" (forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (TyVar -> Kind
tyVarKind TyVar
tyvar))
; forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
tyvar }
newCycleBreakerTyVar :: TcKind -> TcM TcTyVar
newCycleBreakerTyVar :: Kind -> TcM TyVar
newCycleBreakerTyVar Kind
kind
= do { TcTyVarDetails
details <- MetaInfo -> TcM TcTyVarDetails
newMetaDetails MetaInfo
CycleBreakerTv
; Name
name <- FastString -> TcM Name
newMetaTyVarName (String -> FastString
fsLit String
"cbv")
; forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar Name
name Kind
kind TcTyVarDetails
details) }
newMetaDetails :: MetaInfo -> TcM TcTyVarDetails
newMetaDetails :: MetaInfo -> TcM TcTyVarDetails
newMetaDetails MetaInfo
info
= do { IORef MetaDetails
ref <- forall a env. a -> IOEnv env (IORef a)
newMutVar MetaDetails
Flexi
; TcLevel
tclvl <- TcM TcLevel
getTcLevel
; forall (m :: * -> *) a. Monad m => a -> m a
return (MetaTv { mtv_info :: MetaInfo
mtv_info = MetaInfo
info
, mtv_ref :: IORef MetaDetails
mtv_ref = IORef MetaDetails
ref
, mtv_tclvl :: TcLevel
mtv_tclvl = TcLevel
tclvl }) }
newTauTvDetailsAtLevel :: TcLevel -> TcM TcTyVarDetails
newTauTvDetailsAtLevel :: TcLevel -> TcM TcTyVarDetails
newTauTvDetailsAtLevel TcLevel
tclvl
= do { IORef MetaDetails
ref <- forall a env. a -> IOEnv env (IORef a)
newMutVar MetaDetails
Flexi
; forall (m :: * -> *) a. Monad m => a -> m a
return (MetaTv { mtv_info :: MetaInfo
mtv_info = MetaInfo
TauTv
, mtv_ref :: IORef MetaDetails
mtv_ref = IORef MetaDetails
ref
, mtv_tclvl :: TcLevel
mtv_tclvl = TcLevel
tclvl }) }
cloneMetaTyVar :: TcTyVar -> TcM TcTyVar
cloneMetaTyVar :: TyVar -> TcM TyVar
cloneMetaTyVar TyVar
tv
= ASSERT( isTcTyVar tv )
do { IORef MetaDetails
ref <- forall a env. a -> IOEnv env (IORef a)
newMutVar MetaDetails
Flexi
; Name
name' <- Name -> TcM Name
cloneMetaTyVarName (TyVar -> Name
tyVarName TyVar
tv)
; let details' :: TcTyVarDetails
details' = case TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv of
details :: TcTyVarDetails
details@(MetaTv {}) -> TcTyVarDetails
details { mtv_ref :: IORef MetaDetails
mtv_ref = IORef MetaDetails
ref }
TcTyVarDetails
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"cloneMetaTyVar" (forall a. Outputable a => a -> SDoc
ppr TyVar
tv)
tyvar :: TyVar
tyvar = Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar Name
name' (TyVar -> Kind
tyVarKind TyVar
tv) TcTyVarDetails
details'
; String -> SDoc -> TcRn ()
traceTc String
"cloneMetaTyVar" (forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar)
; forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
tyvar }
readMetaTyVar :: TyVar -> TcM MetaDetails
readMetaTyVar :: TyVar -> TcM MetaDetails
readMetaTyVar TyVar
tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
forall a env. IORef a -> IOEnv env a
readMutVar (TyVar -> IORef MetaDetails
metaTyVarRef TyVar
tyvar)
isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type)
isFilledMetaTyVar_maybe :: TyVar -> TcM (Maybe Kind)
isFilledMetaTyVar_maybe TyVar
tv
| MetaTv { mtv_ref :: TcTyVarDetails -> IORef MetaDetails
mtv_ref = IORef MetaDetails
ref } <- TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv
= do { MetaDetails
cts <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef MetaDetails
ref
; case MetaDetails
cts of
Indirect Kind
ty -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Kind
ty)
MetaDetails
Flexi -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
isFilledMetaTyVar :: TyVar -> TcM Bool
isFilledMetaTyVar :: TyVar -> TcM Bool
isFilledMetaTyVar TyVar
tv = forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> TcM (Maybe Kind)
isFilledMetaTyVar_maybe TyVar
tv
isUnfilledMetaTyVar :: TyVar -> TcM Bool
isUnfilledMetaTyVar :: TyVar -> TcM Bool
isUnfilledMetaTyVar TyVar
tv
| MetaTv { mtv_ref :: TcTyVarDetails -> IORef MetaDetails
mtv_ref = IORef MetaDetails
ref } <- TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv
= do { MetaDetails
details <- forall a env. IORef a -> IOEnv env a
readMutVar IORef MetaDetails
ref
; forall (m :: * -> *) a. Monad m => a -> m a
return (MetaDetails -> Bool
isFlexi MetaDetails
details) }
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
writeMetaTyVar :: TyVar -> Kind -> TcRn ()
writeMetaTyVar TyVar
tyvar Kind
ty
| Bool -> Bool
not Bool
debugIsOn
= TyVar -> IORef MetaDetails -> Kind -> TcRn ()
writeMetaTyVarRef TyVar
tyvar (TyVar -> IORef MetaDetails
metaTyVarRef TyVar
tyvar) Kind
ty
| Bool -> Bool
not (TyVar -> Bool
isTcTyVar TyVar
tyvar)
= ASSERT2( False, text "Writing to non-tc tyvar" <+> ppr tyvar )
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| MetaTv { mtv_ref :: TcTyVarDetails -> IORef MetaDetails
mtv_ref = IORef MetaDetails
ref } <- TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tyvar
= TyVar -> IORef MetaDetails -> Kind -> TcRn ()
writeMetaTyVarRef TyVar
tyvar IORef MetaDetails
ref Kind
ty
| Bool
otherwise
= ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar )
forall (m :: * -> *) a. Monad m => a -> m a
return ()
writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
writeMetaTyVarRef :: TyVar -> IORef MetaDetails -> Kind -> TcRn ()
writeMetaTyVarRef TyVar
tyvar IORef MetaDetails
ref Kind
ty
| Bool -> Bool
not Bool
debugIsOn
= do { String -> SDoc -> TcRn ()
traceTc String
"writeMetaTyVar" (forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (TyVar -> Kind
tyVarKind TyVar
tyvar)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
":=" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
ty)
; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef MetaDetails
ref (Kind -> MetaDetails
Indirect Kind
ty) }
| Bool
otherwise
= do { MetaDetails
meta_details <- forall a env. IORef a -> IOEnv env a
readMutVar IORef MetaDetails
ref;
; Kind
zonked_tv_kind <- Kind -> TcM Kind
zonkTcType Kind
tv_kind
; Kind
zonked_ty <- Kind -> TcM Kind
zonkTcType Kind
ty
; let zonked_ty_kind :: Kind
zonked_ty_kind = HasDebugCallStack => Kind -> Kind
tcTypeKind Kind
zonked_ty
zonked_ty_lvl :: TcLevel
zonked_ty_lvl = Kind -> TcLevel
tcTypeLevel Kind
zonked_ty
level_check_ok :: Bool
level_check_ok = Bool -> Bool
not (TcLevel
zonked_ty_lvl TcLevel -> TcLevel -> Bool
`strictlyDeeperThan` TcLevel
tv_lvl)
level_check_msg :: SDoc
level_check_msg = forall a. Outputable a => a -> SDoc
ppr TcLevel
zonked_ty_lvl SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr TcLevel
tv_lvl SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Kind
ty
kind_check_ok :: Bool
kind_check_ok = Kind -> Bool
tcIsConstraintKind Kind
zonked_tv_kind
Bool -> Bool -> Bool
|| HasDebugCallStack => Kind -> Kind -> Bool
tcEqKind Kind
zonked_ty_kind Kind
zonked_tv_kind
kind_msg :: SDoc
kind_msg = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Ill-kinded update to meta tyvar")
Int
2 ( forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> (forall a. Outputable a => a -> SDoc
ppr Kind
tv_kind SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Kind
zonked_tv_kind)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
":="
SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
ty SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> (forall a. Outputable a => a -> SDoc
ppr Kind
zonked_ty_kind) )
; String -> SDoc -> TcRn ()
traceTc String
"writeMetaTyVar" (forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
":=" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
ty)
; MASSERT2( isFlexi meta_details, double_upd_msg meta_details )
; MASSERT2( level_check_ok, level_check_msg )
; MASSERT2( kind_check_ok, kind_msg )
; forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef MetaDetails
ref (Kind -> MetaDetails
Indirect Kind
ty) }
where
tv_kind :: Kind
tv_kind = TyVar -> Kind
tyVarKind TyVar
tyvar
tv_lvl :: TcLevel
tv_lvl = TyVar -> TcLevel
tcTyVarLevel TyVar
tyvar
double_upd_msg :: MetaDetails -> SDoc
double_upd_msg MetaDetails
details = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Double update of meta tyvar")
Int
2 (forall a. Outputable a => a -> SDoc
ppr TyVar
tyvar SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr MetaDetails
details)
newMultiplicityVar :: TcM TcType
newMultiplicityVar :: TcM Kind
newMultiplicityVar = Kind -> TcM Kind
newFlexiTyVarTy Kind
multiplicityTy
newFlexiTyVar :: Kind -> TcM TcTyVar
newFlexiTyVar :: Kind -> TcM TyVar
newFlexiTyVar Kind
kind = MetaInfo -> Kind -> TcM TyVar
newAnonMetaTyVar MetaInfo
TauTv Kind
kind
newNamedFlexiTyVar :: FastString -> Kind -> TcM TcTyVar
newNamedFlexiTyVar :: FastString -> Kind -> TcM TyVar
newNamedFlexiTyVar FastString
fs Kind
kind = FastString -> MetaInfo -> Kind -> TcM TyVar
newNamedAnonMetaTyVar FastString
fs MetaInfo
TauTv Kind
kind
newFlexiTyVarTy :: Kind -> TcM TcType
newFlexiTyVarTy :: Kind -> TcM Kind
newFlexiTyVarTy Kind
kind = do
TyVar
tc_tyvar <- Kind -> TcM TyVar
newFlexiTyVar Kind
kind
forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Kind
mkTyVarTy TyVar
tc_tyvar)
newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
newFlexiTyVarTys :: Int -> Kind -> TcM [Kind]
newFlexiTyVarTys Int
n Kind
kind = forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Kind -> TcM Kind
newFlexiTyVarTy Kind
kind)
newOpenTypeKind :: TcM TcKind
newOpenTypeKind :: TcM Kind
newOpenTypeKind
= do { Kind
rr <- Kind -> TcM Kind
newFlexiTyVarTy Kind
runtimeRepTy
; forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Kind
tYPE Kind
rr) }
newOpenFlexiTyVarTy :: TcM TcType
newOpenFlexiTyVarTy :: TcM Kind
newOpenFlexiTyVarTy
= do { TyVar
tv <- TcM TyVar
newOpenFlexiTyVar
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Kind
mkTyVarTy TyVar
tv) }
newOpenFlexiTyVar :: TcM TcTyVar
newOpenFlexiTyVar :: TcM TyVar
newOpenFlexiTyVar
= do { Kind
kind <- TcM Kind
newOpenTypeKind
; Kind -> TcM TyVar
newFlexiTyVar Kind
kind }
newOpenBoxedTypeKind :: TcM TcKind
newOpenBoxedTypeKind :: TcM Kind
newOpenBoxedTypeKind
= do { Kind
lev <- Kind -> TcM Kind
newFlexiTyVarTy (TyCon -> Kind
mkTyConTy TyCon
levityTyCon)
; let rr :: Kind
rr = TyCon -> [Kind] -> Kind
mkTyConApp TyCon
boxedRepDataConTyCon [Kind
lev]
; forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Kind
tYPE Kind
rr) }
newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TyVar])
newMetaTyVars = TCvSubst -> [TyVar] -> TcM (TCvSubst, [TyVar])
newMetaTyVarsX TCvSubst
emptyTCvSubst
newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TyVar])
newMetaTyVarsX TCvSubst
subst = forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM TCvSubst -> TyVar -> TcM (TCvSubst, TyVar)
newMetaTyVarX TCvSubst
subst
newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TyVar)
newMetaTyVarX = MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TyVar)
new_meta_tv_x MetaInfo
TauTv
newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TyVar)
newMetaTyVarTyVarX = MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TyVar)
new_meta_tv_x MetaInfo
TyVarTv
newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TyVar)
newWildCardX TCvSubst
subst TyVar
tv
= do { TyVar
new_tv <- MetaInfo -> Kind -> TcM TyVar
newAnonMetaTyVar MetaInfo
TauTv (HasCallStack => TCvSubst -> Kind -> Kind
substTy TCvSubst
subst (TyVar -> Kind
tyVarKind TyVar
tv))
; forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst -> TyVar -> TyVar -> TCvSubst
extendTvSubstWithClone TCvSubst
subst TyVar
tv TyVar
new_tv, TyVar
new_tv) }
new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TyVar)
new_meta_tv_x MetaInfo
info TCvSubst
subst TyVar
tv
= do { TyVar
new_tv <- MetaInfo -> TyVar -> Kind -> TcM TyVar
cloneAnonMetaTyVar MetaInfo
info TyVar
tv Kind
substd_kind
; let subst1 :: TCvSubst
subst1 = TCvSubst -> TyVar -> TyVar -> TCvSubst
extendTvSubstWithClone TCvSubst
subst TyVar
tv TyVar
new_tv
; forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst1, TyVar
new_tv) }
where
substd_kind :: Kind
substd_kind = TCvSubst -> Kind -> Kind
substTyUnchecked TCvSubst
subst (TyVar -> Kind
tyVarKind TyVar
tv)
newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType
newMetaTyVarTyAtLevel :: TcLevel -> Kind -> TcM Kind
newMetaTyVarTyAtLevel TcLevel
tc_lvl Kind
kind
= do { TcTyVarDetails
details <- TcLevel -> TcM TcTyVarDetails
newTauTvDetailsAtLevel TcLevel
tc_lvl
; Name
name <- FastString -> TcM Name
newMetaTyVarName (String -> FastString
fsLit String
"p")
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Kind
mkTyVarTy (Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar Name
name Kind
kind TcTyVarDetails
details)) }
data CandidatesQTvs
= DV { CandidatesQTvs -> DTyVarSet
dv_kvs :: DTyVarSet
, CandidatesQTvs -> DTyVarSet
dv_tvs :: DTyVarSet
, CandidatesQTvs -> CoVarSet
dv_cvs :: CoVarSet
}
instance Semi.Semigroup CandidatesQTvs where
(DV { dv_kvs :: CandidatesQTvs -> DTyVarSet
dv_kvs = DTyVarSet
kv1, dv_tvs :: CandidatesQTvs -> DTyVarSet
dv_tvs = DTyVarSet
tv1, dv_cvs :: CandidatesQTvs -> CoVarSet
dv_cvs = CoVarSet
cv1 })
<> :: CandidatesQTvs -> CandidatesQTvs -> CandidatesQTvs
<> (DV { dv_kvs :: CandidatesQTvs -> DTyVarSet
dv_kvs = DTyVarSet
kv2, dv_tvs :: CandidatesQTvs -> DTyVarSet
dv_tvs = DTyVarSet
tv2, dv_cvs :: CandidatesQTvs -> CoVarSet
dv_cvs = CoVarSet
cv2 })
= DV { dv_kvs :: DTyVarSet
dv_kvs = DTyVarSet
kv1 DTyVarSet -> DTyVarSet -> DTyVarSet
`unionDVarSet` DTyVarSet
kv2
, dv_tvs :: DTyVarSet
dv_tvs = DTyVarSet
tv1 DTyVarSet -> DTyVarSet -> DTyVarSet
`unionDVarSet` DTyVarSet
tv2
, dv_cvs :: CoVarSet
dv_cvs = CoVarSet
cv1 CoVarSet -> CoVarSet -> CoVarSet
`unionVarSet` CoVarSet
cv2 }
instance Monoid CandidatesQTvs where
mempty :: CandidatesQTvs
mempty = DV { dv_kvs :: DTyVarSet
dv_kvs = DTyVarSet
emptyDVarSet, dv_tvs :: DTyVarSet
dv_tvs = DTyVarSet
emptyDVarSet, dv_cvs :: CoVarSet
dv_cvs = CoVarSet
emptyVarSet }
mappend :: CandidatesQTvs -> CandidatesQTvs -> CandidatesQTvs
mappend = forall a. Semigroup a => a -> a -> a
(Semi.<>)
instance Outputable CandidatesQTvs where
ppr :: CandidatesQTvs -> SDoc
ppr (DV {dv_kvs :: CandidatesQTvs -> DTyVarSet
dv_kvs = DTyVarSet
kvs, dv_tvs :: CandidatesQTvs -> DTyVarSet
dv_tvs = DTyVarSet
tvs, dv_cvs :: CandidatesQTvs -> CoVarSet
dv_cvs = CoVarSet
cvs })
= String -> SDoc
text String
"DV" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces (forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas forall a. a -> a
id [ String -> SDoc
text String
"dv_kvs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr DTyVarSet
kvs
, String -> SDoc
text String
"dv_tvs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr DTyVarSet
tvs
, String -> SDoc
text String
"dv_cvs =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CoVarSet
cvs ])
isEmptyCandidates :: CandidatesQTvs -> Bool
isEmptyCandidates :: CandidatesQTvs -> Bool
isEmptyCandidates (DV { dv_kvs :: CandidatesQTvs -> DTyVarSet
dv_kvs = DTyVarSet
kvs, dv_tvs :: CandidatesQTvs -> DTyVarSet
dv_tvs = DTyVarSet
tvs })
= DTyVarSet -> Bool
isEmptyDVarSet DTyVarSet
kvs Bool -> Bool -> Bool
&& DTyVarSet -> Bool
isEmptyDVarSet DTyVarSet
tvs
candidateVars :: CandidatesQTvs -> ([TcTyVar], [TcTyVar])
candidateVars :: CandidatesQTvs -> ([TyVar], [TyVar])
candidateVars (DV { dv_kvs :: CandidatesQTvs -> DTyVarSet
dv_kvs = DTyVarSet
dep_kv_set, dv_tvs :: CandidatesQTvs -> DTyVarSet
dv_tvs = DTyVarSet
nondep_tkv_set })
= ([TyVar]
dep_kvs, [TyVar]
nondep_tvs)
where
dep_kvs :: [TyVar]
dep_kvs = [TyVar] -> [TyVar]
scopedSort forall a b. (a -> b) -> a -> b
$ DTyVarSet -> [TyVar]
dVarSetElems DTyVarSet
dep_kv_set
nondep_tvs :: [TyVar]
nondep_tvs = DTyVarSet -> [TyVar]
dVarSetElems (DTyVarSet
nondep_tkv_set DTyVarSet -> DTyVarSet -> DTyVarSet
`minusDVarSet` DTyVarSet
dep_kv_set)
candidateKindVars :: CandidatesQTvs -> TyVarSet
candidateKindVars :: CandidatesQTvs -> CoVarSet
candidateKindVars CandidatesQTvs
dvs = DTyVarSet -> CoVarSet
dVarSetToVarSet (CandidatesQTvs -> DTyVarSet
dv_kvs CandidatesQTvs
dvs)
partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs)
partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (CoVarSet, CandidatesQTvs)
partitionCandidates dvs :: CandidatesQTvs
dvs@(DV { dv_kvs :: CandidatesQTvs -> DTyVarSet
dv_kvs = DTyVarSet
kvs, dv_tvs :: CandidatesQTvs -> DTyVarSet
dv_tvs = DTyVarSet
tvs }) TyVar -> Bool
pred
= (CoVarSet
extracted, CandidatesQTvs
dvs { dv_kvs :: DTyVarSet
dv_kvs = DTyVarSet
rest_kvs, dv_tvs :: DTyVarSet
dv_tvs = DTyVarSet
rest_tvs })
where
(DTyVarSet
extracted_kvs, DTyVarSet
rest_kvs) = (TyVar -> Bool) -> DTyVarSet -> (DTyVarSet, DTyVarSet)
partitionDVarSet TyVar -> Bool
pred DTyVarSet
kvs
(DTyVarSet
extracted_tvs, DTyVarSet
rest_tvs) = (TyVar -> Bool) -> DTyVarSet -> (DTyVarSet, DTyVarSet)
partitionDVarSet TyVar -> Bool
pred DTyVarSet
tvs
extracted :: CoVarSet
extracted = DTyVarSet -> CoVarSet
dVarSetToVarSet DTyVarSet
extracted_kvs CoVarSet -> CoVarSet -> CoVarSet
`unionVarSet` DTyVarSet -> CoVarSet
dVarSetToVarSet DTyVarSet
extracted_tvs
candidateQTyVarsOfType :: TcType
-> TcM CandidatesQTvs
candidateQTyVarsOfType :: Kind -> TcM CandidatesQTvs
candidateQTyVarsOfType Kind
ty = Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
ty Bool
False CoVarSet
emptyVarSet forall a. Monoid a => a
mempty Kind
ty
candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes :: [Kind] -> TcM CandidatesQTvs
candidateQTyVarsOfTypes [Kind]
tys = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (\CandidatesQTvs
acc Kind
ty -> Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
ty Bool
False CoVarSet
emptyVarSet CandidatesQTvs
acc Kind
ty)
forall a. Monoid a => a
mempty [Kind]
tys
candidateQTyVarsOfKind :: TcKind
-> TcM CandidatesQTvs
candidateQTyVarsOfKind :: Kind -> TcM CandidatesQTvs
candidateQTyVarsOfKind Kind
ty = Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
ty Bool
True CoVarSet
emptyVarSet forall a. Monoid a => a
mempty Kind
ty
candidateQTyVarsOfKinds :: [TcKind]
-> TcM CandidatesQTvs
candidateQTyVarsOfKinds :: [Kind] -> TcM CandidatesQTvs
candidateQTyVarsOfKinds [Kind]
tys = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\CandidatesQTvs
acc Kind
ty -> Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
ty Bool
True CoVarSet
emptyVarSet CandidatesQTvs
acc Kind
ty)
forall a. Monoid a => a
mempty [Kind]
tys
delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs
delCandidates :: CandidatesQTvs -> [TyVar] -> CandidatesQTvs
delCandidates (DV { dv_kvs :: CandidatesQTvs -> DTyVarSet
dv_kvs = DTyVarSet
kvs, dv_tvs :: CandidatesQTvs -> DTyVarSet
dv_tvs = DTyVarSet
tvs, dv_cvs :: CandidatesQTvs -> CoVarSet
dv_cvs = CoVarSet
cvs }) [TyVar]
vars
= DV { dv_kvs :: DTyVarSet
dv_kvs = DTyVarSet
kvs DTyVarSet -> [TyVar] -> DTyVarSet
`delDVarSetList` [TyVar]
vars
, dv_tvs :: DTyVarSet
dv_tvs = DTyVarSet
tvs DTyVarSet -> [TyVar] -> DTyVarSet
`delDVarSetList` [TyVar]
vars
, dv_cvs :: CoVarSet
dv_cvs = CoVarSet
cvs CoVarSet -> [TyVar] -> CoVarSet
`delVarSetList` [TyVar]
vars }
collect_cand_qtvs
:: TcType
-> Bool
-> VarSet
-> CandidatesQTvs
-> Type
-> TcM CandidatesQTvs
collect_cand_qtvs :: Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
orig_ty Bool
is_dep CoVarSet
bound CandidatesQTvs
dvs Kind
ty
= CandidatesQTvs -> Kind -> TcM CandidatesQTvs
go CandidatesQTvs
dvs Kind
ty
where
is_bound :: TyVar -> Bool
is_bound TyVar
tv = TyVar
tv TyVar -> CoVarSet -> Bool
`elemVarSet` CoVarSet
bound
go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs
go :: CandidatesQTvs -> Kind -> TcM CandidatesQTvs
go CandidatesQTvs
dv (AppTy Kind
t1 Kind
t2) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CandidatesQTvs -> Kind -> TcM CandidatesQTvs
go CandidatesQTvs
dv [Kind
t1, Kind
t2]
go CandidatesQTvs
dv (TyConApp TyCon
tc [Kind]
tys) = CandidatesQTvs -> [TyConBinder] -> [Kind] -> TcM CandidatesQTvs
go_tc_args CandidatesQTvs
dv (TyCon -> [TyConBinder]
tyConBinders TyCon
tc) [Kind]
tys
go CandidatesQTvs
dv (FunTy AnonArgFlag
_ Kind
w Kind
arg Kind
res) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CandidatesQTvs -> Kind -> TcM CandidatesQTvs
go CandidatesQTvs
dv [Kind
w, Kind
arg, Kind
res]
go CandidatesQTvs
dv (LitTy {}) = forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dv
go CandidatesQTvs
dv (CastTy Kind
ty Coercion
co) = do CandidatesQTvs
dv1 <- CandidatesQTvs -> Kind -> TcM CandidatesQTvs
go CandidatesQTvs
dv Kind
ty
Kind
-> CoVarSet -> CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
collect_cand_qtvs_co Kind
orig_ty CoVarSet
bound CandidatesQTvs
dv1 Coercion
co
go CandidatesQTvs
dv (CoercionTy Coercion
co) = Kind
-> CoVarSet -> CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
collect_cand_qtvs_co Kind
orig_ty CoVarSet
bound CandidatesQTvs
dv Coercion
co
go CandidatesQTvs
dv (TyVarTy TyVar
tv)
| TyVar -> Bool
is_bound TyVar
tv = forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dv
| Bool
otherwise = do { Maybe Kind
m_contents <- TyVar -> TcM (Maybe Kind)
isFilledMetaTyVar_maybe TyVar
tv
; case Maybe Kind
m_contents of
Just Kind
ind_ty -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
go CandidatesQTvs
dv Kind
ind_ty
Maybe Kind
Nothing -> CandidatesQTvs -> TyVar -> TcM CandidatesQTvs
go_tv CandidatesQTvs
dv TyVar
tv }
go CandidatesQTvs
dv (ForAllTy (Bndr TyVar
tv ArgFlag
_) Kind
ty)
= do { CandidatesQTvs
dv1 <- Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
orig_ty Bool
True CoVarSet
bound CandidatesQTvs
dv (TyVar -> Kind
tyVarKind TyVar
tv)
; Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
orig_ty Bool
is_dep (CoVarSet
bound CoVarSet -> TyVar -> CoVarSet
`extendVarSet` TyVar
tv) CandidatesQTvs
dv1 Kind
ty }
go_tc_args :: CandidatesQTvs -> [TyConBinder] -> [Kind] -> TcM CandidatesQTvs
go_tc_args CandidatesQTvs
dv (TyConBinder
tc_bndr:[TyConBinder]
tc_bndrs) (Kind
ty:[Kind]
tys)
= do { CandidatesQTvs
dv1 <- Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
orig_ty (Bool
is_dep Bool -> Bool -> Bool
|| TyConBinder -> Bool
isNamedTyConBinder TyConBinder
tc_bndr)
CoVarSet
bound CandidatesQTvs
dv Kind
ty
; CandidatesQTvs -> [TyConBinder] -> [Kind] -> TcM CandidatesQTvs
go_tc_args CandidatesQTvs
dv1 [TyConBinder]
tc_bndrs [Kind]
tys }
go_tc_args CandidatesQTvs
dv [TyConBinder]
_bndrs [Kind]
tys
= forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CandidatesQTvs -> Kind -> TcM CandidatesQTvs
go CandidatesQTvs
dv [Kind]
tys
go_tv :: CandidatesQTvs -> TyVar -> TcM CandidatesQTvs
go_tv dv :: CandidatesQTvs
dv@(DV { dv_kvs :: CandidatesQTvs -> DTyVarSet
dv_kvs = DTyVarSet
kvs, dv_tvs :: CandidatesQTvs -> DTyVarSet
dv_tvs = DTyVarSet
tvs }) TyVar
tv
| TyVar
tv TyVar -> DTyVarSet -> Bool
`elemDVarSet` DTyVarSet
kvs
= forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dv
| Bool -> Bool
not Bool
is_dep
, TyVar
tv TyVar -> DTyVarSet -> Bool
`elemDVarSet` DTyVarSet
tvs
= forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dv
| Bool
otherwise
= do { Kind
tv_kind <- Kind -> TcM Kind
zonkTcType (TyVar -> Kind
tyVarKind TyVar
tv)
; let tv_kind_vars :: CoVarSet
tv_kind_vars = Kind -> CoVarSet
tyCoVarsOfType Kind
tv_kind
; TcLevel
cur_lvl <- TcM TcLevel
getTcLevel
; if | TyVar -> TcLevel
tcTyVarLevel TyVar
tv forall a. Ord a => a -> a -> Bool
<= TcLevel
cur_lvl
-> forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dv
| CoVarSet -> CoVarSet -> Bool
intersectsVarSet CoVarSet
bound CoVarSet
tv_kind_vars
-> do { String -> SDoc -> TcRn ()
traceTc String
"Naughty quantifier" forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr TyVar
tv SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
tv_kind
, String -> SDoc
text String
"bound:" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars (forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet CoVarSet
bound)
, String -> SDoc
text String
"fvs:" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars (forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet CoVarSet
tv_kind_vars) ]
; let escapees :: CoVarSet
escapees = CoVarSet -> CoVarSet -> CoVarSet
intersectVarSet CoVarSet
bound CoVarSet
tv_kind_vars
; forall a. Kind -> TyVar -> CoVarSet -> TcM a
naughtyQuantification Kind
orig_ty TyVar
tv CoVarSet
escapees }
| Bool
otherwise
-> do { let tv' :: TyVar
tv' = TyVar
tv TyVar -> Kind -> TyVar
`setTyVarKind` Kind
tv_kind
dv' :: CandidatesQTvs
dv' | Bool
is_dep = CandidatesQTvs
dv { dv_kvs :: DTyVarSet
dv_kvs = DTyVarSet
kvs DTyVarSet -> TyVar -> DTyVarSet
`extendDVarSet` TyVar
tv' }
| Bool
otherwise = CandidatesQTvs
dv { dv_tvs :: DTyVarSet
dv_tvs = DTyVarSet
tvs DTyVarSet -> TyVar -> DTyVarSet
`extendDVarSet` TyVar
tv' }
; Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
orig_ty Bool
True CoVarSet
bound CandidatesQTvs
dv' Kind
tv_kind } }
collect_cand_qtvs_co :: TcType
-> VarSet
-> CandidatesQTvs -> Coercion
-> TcM CandidatesQTvs
collect_cand_qtvs_co :: Kind
-> CoVarSet -> CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
collect_cand_qtvs_co Kind
orig_ty CoVarSet
bound = CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co
where
go_co :: CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv (Refl Kind
ty) = Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
orig_ty Bool
True CoVarSet
bound CandidatesQTvs
dv Kind
ty
go_co CandidatesQTvs
dv (GRefl Role
_ Kind
ty MCoercionN
mco) = do CandidatesQTvs
dv1 <- Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
orig_ty Bool
True CoVarSet
bound CandidatesQTvs
dv Kind
ty
CandidatesQTvs -> MCoercionN -> TcM CandidatesQTvs
go_mco CandidatesQTvs
dv1 MCoercionN
mco
go_co CandidatesQTvs
dv (TyConAppCo Role
_ TyCon
_ [Coercion]
cos) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv [Coercion]
cos
go_co CandidatesQTvs
dv (AppCo Coercion
co1 Coercion
co2) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv [Coercion
co1, Coercion
co2]
go_co CandidatesQTvs
dv (FunCo Role
_ Coercion
w Coercion
co1 Coercion
co2) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv [Coercion
w, Coercion
co1, Coercion
co2]
go_co CandidatesQTvs
dv (AxiomInstCo CoAxiom Branched
_ Int
_ [Coercion]
cos) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv [Coercion]
cos
go_co CandidatesQTvs
dv (AxiomRuleCo CoAxiomRule
_ [Coercion]
cos) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv [Coercion]
cos
go_co CandidatesQTvs
dv (UnivCo UnivCoProvenance
prov Role
_ Kind
t1 Kind
t2) = do CandidatesQTvs
dv1 <- CandidatesQTvs -> UnivCoProvenance -> TcM CandidatesQTvs
go_prov CandidatesQTvs
dv UnivCoProvenance
prov
CandidatesQTvs
dv2 <- Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
orig_ty Bool
True CoVarSet
bound CandidatesQTvs
dv1 Kind
t1
Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
orig_ty Bool
True CoVarSet
bound CandidatesQTvs
dv2 Kind
t2
go_co CandidatesQTvs
dv (SymCo Coercion
co) = CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv Coercion
co
go_co CandidatesQTvs
dv (TransCo Coercion
co1 Coercion
co2) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv [Coercion
co1, Coercion
co2]
go_co CandidatesQTvs
dv (NthCo Role
_ Int
_ Coercion
co) = CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv Coercion
co
go_co CandidatesQTvs
dv (LRCo LeftOrRight
_ Coercion
co) = CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv Coercion
co
go_co CandidatesQTvs
dv (InstCo Coercion
co1 Coercion
co2) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv [Coercion
co1, Coercion
co2]
go_co CandidatesQTvs
dv (KindCo Coercion
co) = CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv Coercion
co
go_co CandidatesQTvs
dv (SubCo Coercion
co) = CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv Coercion
co
go_co CandidatesQTvs
dv (HoleCo CoercionHole
hole)
= do Maybe Coercion
m_co <- CoercionHole -> TcM (Maybe Coercion)
unpackCoercionHole_maybe CoercionHole
hole
case Maybe Coercion
m_co of
Just Coercion
co -> CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv Coercion
co
Maybe Coercion
Nothing -> CandidatesQTvs -> TyVar -> TcM CandidatesQTvs
go_cv CandidatesQTvs
dv (CoercionHole -> TyVar
coHoleCoVar CoercionHole
hole)
go_co CandidatesQTvs
dv (CoVarCo TyVar
cv) = CandidatesQTvs -> TyVar -> TcM CandidatesQTvs
go_cv CandidatesQTvs
dv TyVar
cv
go_co CandidatesQTvs
dv (ForAllCo TyVar
tcv Coercion
kind_co Coercion
co)
= do { CandidatesQTvs
dv1 <- CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv Coercion
kind_co
; Kind
-> CoVarSet -> CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
collect_cand_qtvs_co Kind
orig_ty (CoVarSet
bound CoVarSet -> TyVar -> CoVarSet
`extendVarSet` TyVar
tcv) CandidatesQTvs
dv1 Coercion
co }
go_mco :: CandidatesQTvs -> MCoercionN -> TcM CandidatesQTvs
go_mco CandidatesQTvs
dv MCoercionN
MRefl = forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dv
go_mco CandidatesQTvs
dv (MCo Coercion
co) = CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv Coercion
co
go_prov :: CandidatesQTvs -> UnivCoProvenance -> TcM CandidatesQTvs
go_prov CandidatesQTvs
dv (PhantomProv Coercion
co) = CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv Coercion
co
go_prov CandidatesQTvs
dv (ProofIrrelProv Coercion
co) = CandidatesQTvs -> Coercion -> TcM CandidatesQTvs
go_co CandidatesQTvs
dv Coercion
co
go_prov CandidatesQTvs
dv (PluginProv String
_) = forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dv
go_prov CandidatesQTvs
dv (CorePrepProv Bool
_) = forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dv
go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs
go_cv :: CandidatesQTvs -> TyVar -> TcM CandidatesQTvs
go_cv dv :: CandidatesQTvs
dv@(DV { dv_cvs :: CandidatesQTvs -> CoVarSet
dv_cvs = CoVarSet
cvs }) TyVar
cv
| TyVar -> Bool
is_bound TyVar
cv = forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dv
| TyVar
cv TyVar -> CoVarSet -> Bool
`elemVarSet` CoVarSet
cvs = forall (m :: * -> *) a. Monad m => a -> m a
return CandidatesQTvs
dv
| Bool
otherwise = Kind
-> Bool -> CoVarSet -> CandidatesQTvs -> Kind -> TcM CandidatesQTvs
collect_cand_qtvs Kind
orig_ty Bool
True CoVarSet
bound
(CandidatesQTvs
dv { dv_cvs :: CoVarSet
dv_cvs = CoVarSet
cvs CoVarSet -> TyVar -> CoVarSet
`extendVarSet` TyVar
cv })
(TyVar -> Kind
idType TyVar
cv)
is_bound :: TyVar -> Bool
is_bound TyVar
tv = TyVar
tv TyVar -> CoVarSet -> Bool
`elemVarSet` CoVarSet
bound
quantifyTyVars :: CandidatesQTvs
-> TcM [TcTyVar]
quantifyTyVars :: CandidatesQTvs -> TcM [TyVar]
quantifyTyVars CandidatesQTvs
dvs
| CandidatesQTvs -> Bool
isEmptyCandidates CandidatesQTvs
dvs
= do { String -> SDoc -> TcRn ()
traceTc String
"quantifyTyVars has nothing to quantify" SDoc
empty
; forall (m :: * -> *) a. Monad m => a -> m a
return [] }
| Bool
otherwise
= do { String -> SDoc -> TcRn ()
traceTc String
"quantifyTyVars {" (forall a. Outputable a => a -> SDoc
ppr CandidatesQTvs
dvs)
; [TyVar]
undefaulted <- CandidatesQTvs -> TcM [TyVar]
defaultTyVars CandidatesQTvs
dvs
; [TyVar]
final_qtvs <- forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM TyVar -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TyVar)
zonk_quant [TyVar]
undefaulted
; String -> SDoc -> TcRn ()
traceTc String
"quantifyTyVars }"
([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"undefaulted:" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
undefaulted
, String -> SDoc
text String
"final_qtvs:" SDoc -> SDoc -> SDoc
<+> [TyVar] -> SDoc
pprTyVars [TyVar]
final_qtvs ])
; let co_vars :: [TyVar]
co_vars = forall a. (a -> Bool) -> [a] -> [a]
filter TyVar -> Bool
isCoVar [TyVar]
final_qtvs
; MASSERT2( null co_vars, ppr co_vars )
; forall (m :: * -> *) a. Monad m => a -> m a
return [TyVar]
final_qtvs }
where
zonk_quant :: TyVar -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe TyVar)
zonk_quant TyVar
tkv
| Bool -> Bool
not (TyVar -> Bool
isTyVar TyVar
tkv)
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Bool -> Bool
not (TyVar -> Bool
isTcTyVar TyVar
tkv)
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just TyVar
tkv)
| Bool
otherwise
= forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> TcM TyVar
skolemiseQuantifiedTyVar TyVar
tkv
isQuantifiableTv :: TcLevel
-> TcTyVar
-> Bool
isQuantifiableTv :: TcLevel -> TyVar -> Bool
isQuantifiableTv TcLevel
outer_tclvl TyVar
tcv
| TyVar -> Bool
isTcTyVar TyVar
tcv
= TyVar -> TcLevel
tcTyVarLevel TyVar
tcv forall a. Ord a => a -> a -> Bool
> TcLevel
outer_tclvl
| Bool
otherwise
= Bool
False
zonkAndSkolemise :: TcTyCoVar -> TcM TcTyCoVar
zonkAndSkolemise :: TyVar -> TcM TyVar
zonkAndSkolemise TyVar
tyvar
| TyVar -> Bool
isTyVarTyVar TyVar
tyvar
= do { TyVar
zonked_tyvar <- HasDebugCallStack => TyVar -> TcM TyVar
zonkTcTyVarToTyVar TyVar
tyvar
; TyVar -> TcM TyVar
skolemiseQuantifiedTyVar TyVar
zonked_tyvar }
| Bool
otherwise
= ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar )
TyVar -> TcM TyVar
zonkTyCoVarKind TyVar
tyvar
skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
skolemiseQuantifiedTyVar :: TyVar -> TcM TyVar
skolemiseQuantifiedTyVar TyVar
tv
= case TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv of
SkolemTv {} -> do { Kind
kind <- Kind -> TcM Kind
zonkTcType (TyVar -> Kind
tyVarKind TyVar
tv)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Kind -> TyVar
setTyVarKind TyVar
tv Kind
kind) }
MetaTv {} -> TyVar -> TcM TyVar
skolemiseUnboundMetaTyVar TyVar
tv
TcTyVarDetails
_other -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"skolemiseQuantifiedTyVar" (forall a. Outputable a => a -> SDoc
ppr TyVar
tv)
defaultTyVar :: Bool
-> TcTyVar
-> TcM Bool
defaultTyVar :: Bool -> TyVar -> TcM Bool
defaultTyVar Bool
default_kind TyVar
tv
| Bool -> Bool
not (TyVar -> Bool
isMetaTyVar TyVar
tv)
= forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| TyVar -> Bool
isTyVarTyVar TyVar
tv
= forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| TyVar -> Bool
isRuntimeRepVar TyVar
tv
= do { String -> SDoc -> TcRn ()
traceTc String
"Defaulting a RuntimeRep var to LiftedRep" (forall a. Outputable a => a -> SDoc
ppr TyVar
tv)
; TyVar -> Kind -> TcRn ()
writeMetaTyVar TyVar
tv Kind
liftedRepTy
; forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True }
| TyVar -> Bool
isLevityVar TyVar
tv
= do { String -> SDoc -> TcRn ()
traceTc String
"Defaulting a Levity var to Lifted" (forall a. Outputable a => a -> SDoc
ppr TyVar
tv)
; TyVar -> Kind -> TcRn ()
writeMetaTyVar TyVar
tv Kind
liftedDataConTy
; forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True }
| TyVar -> Bool
isMultiplicityVar TyVar
tv
= do { String -> SDoc -> TcRn ()
traceTc String
"Defaulting a Multiplicty var to Many" (forall a. Outputable a => a -> SDoc
ppr TyVar
tv)
; TyVar -> Kind -> TcRn ()
writeMetaTyVar TyVar
tv Kind
manyDataConTy
; forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True }
| Bool
default_kind
= TyVar -> TcM Bool
default_kind_var TyVar
tv
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
where
default_kind_var :: TyVar -> TcM Bool
default_kind_var :: TyVar -> TcM Bool
default_kind_var TyVar
kv
| Kind -> Bool
isLiftedTypeKind (TyVar -> Kind
tyVarKind TyVar
kv)
= do { String -> SDoc -> TcRn ()
traceTc String
"Defaulting a kind var to *" (forall a. Outputable a => a -> SDoc
ppr TyVar
kv)
; TyVar -> Kind -> TcRn ()
writeMetaTyVar TyVar
kv Kind
liftedTypeKind
; forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True }
| Bool
otherwise
= do { SDoc -> TcRn ()
addErr ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Cannot default kind variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr TyVar
kv')
, String -> SDoc
text String
"of kind:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (TyVar -> Kind
tyVarKind TyVar
kv')
, String -> SDoc
text String
"Perhaps enable PolyKinds or add a kind signature" ])
; forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
}
where
(TidyEnv
_, TyVar
kv') = TidyEnv -> TyVar -> (TidyEnv, TyVar)
tidyOpenTyCoVar TidyEnv
emptyTidyEnv TyVar
kv
defaultTyVars :: CandidatesQTvs
-> TcM [TcTyVar]
defaultTyVars :: CandidatesQTvs -> TcM [TyVar]
defaultTyVars CandidatesQTvs
dvs
= do { Bool
poly_kinds <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PolyKinds
; [Bool]
defaulted_kvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> TyVar -> TcM Bool
defaultTyVar (Bool -> Bool
not Bool
poly_kinds)) [TyVar]
dep_kvs
; [Bool]
defaulted_tvs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> TyVar -> TcM Bool
defaultTyVar Bool
False) [TyVar]
nondep_tvs
; let undefaulted_kvs :: [TyVar]
undefaulted_kvs = [ TyVar
kv | (TyVar
kv, Bool
False) <- [TyVar]
dep_kvs forall a b. [a] -> [b] -> [(a, b)]
`zip` [Bool]
defaulted_kvs ]
undefaulted_tvs :: [TyVar]
undefaulted_tvs = [ TyVar
tv | (TyVar
tv, Bool
False) <- [TyVar]
nondep_tvs forall a b. [a] -> [b] -> [(a, b)]
`zip` [Bool]
defaulted_tvs ]
; forall (m :: * -> *) a. Monad m => a -> m a
return ([TyVar]
undefaulted_kvs forall a. [a] -> [a] -> [a]
++ [TyVar]
undefaulted_tvs) }
where
([TyVar]
dep_kvs, [TyVar]
nondep_tvs) = CandidatesQTvs -> ([TyVar], [TyVar])
candidateVars CandidatesQTvs
dvs
skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar
skolemiseUnboundMetaTyVar :: TyVar -> TcM TyVar
skolemiseUnboundMetaTyVar TyVar
tv
= ASSERT2( isMetaTyVar tv, ppr tv )
do { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugIsOn (TyVar -> TcRn ()
check_empty TyVar
tv)
; SrcSpan
here <- TcRn SrcSpan
getSrcSpanM
; Kind
kind <- Kind -> TcM Kind
zonkTcType (TyVar -> Kind
tyVarKind TyVar
tv)
; let tv_name :: Name
tv_name = TyVar -> Name
tyVarName TyVar
tv
final_name :: Name
final_name | Name -> Bool
isSystemName Name
tv_name
= Unique -> OccName -> SrcSpan -> Name
mkInternalName (Name -> Unique
nameUnique Name
tv_name)
(Name -> OccName
nameOccName Name
tv_name) SrcSpan
here
| Bool
otherwise
= Name
tv_name
final_tv :: TyVar
final_tv = Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar Name
final_name Kind
kind TcTyVarDetails
details
; String -> SDoc -> TcRn ()
traceTc String
"Skolemising" (forall a. Outputable a => a -> SDoc
ppr TyVar
tv SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
":=" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyVar
final_tv)
; TyVar -> Kind -> TcRn ()
writeMetaTyVar TyVar
tv (TyVar -> Kind
mkTyVarTy TyVar
final_tv)
; forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
final_tv }
where
details :: TcTyVarDetails
details = TcLevel -> Bool -> TcTyVarDetails
SkolemTv (TyVar -> TcLevel
metaTyVarTcLevel TyVar
tv) Bool
False
check_empty :: TyVar -> TcRn ()
check_empty TyVar
tv
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugIsOn forall a b. (a -> b) -> a -> b
$
do { MetaDetails
cts <- TyVar -> TcM MetaDetails
readMetaTyVar TyVar
tv
; case MetaDetails
cts of
MetaDetails
Flexi -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Indirect Kind
ty -> WARN( True, ppr tv $$ ppr ty )
forall (m :: * -> *) a. Monad m => a -> m a
return () }
doNotQuantifyTyVars :: CandidatesQTvs
-> (TidyEnv -> TcM (TidyEnv, SDoc))
-> TcM ()
doNotQuantifyTyVars :: CandidatesQTvs -> (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcRn ()
doNotQuantifyTyVars CandidatesQTvs
dvs TidyEnv -> TcM (TidyEnv, SDoc)
where_found
| CandidatesQTvs -> Bool
isEmptyCandidates CandidatesQTvs
dvs
= String -> SDoc -> TcRn ()
traceTc String
"doNotQuantifyTyVars has nothing to error on" SDoc
empty
| Bool
otherwise
= do { String -> SDoc -> TcRn ()
traceTc String
"doNotQuantifyTyVars" (forall a. Outputable a => a -> SDoc
ppr CandidatesQTvs
dvs)
; [TyVar]
undefaulted <- CandidatesQTvs -> TcM [TyVar]
defaultTyVars CandidatesQTvs
dvs
; let leftover_metas :: [TyVar]
leftover_metas = forall a. (a -> Bool) -> [a] -> [a]
filter TyVar -> Bool
isMetaTyVar [TyVar]
undefaulted
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVar]
leftover_metas) forall a b. (a -> b) -> a -> b
$
do { let (TidyEnv
tidy_env1, [TyVar]
tidied_tvs) = TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
tidyOpenTyCoVars TidyEnv
emptyTidyEnv [TyVar]
leftover_metas
; (TidyEnv
tidy_env2, SDoc
where_doc) <- TidyEnv -> TcM (TidyEnv, SDoc)
where_found TidyEnv
tidy_env1
; let doc :: SDoc
doc = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Uninferrable type variable"
SDoc -> SDoc -> SDoc
<> forall a. [a] -> SDoc
plural [TyVar]
tidied_tvs
SDoc -> SDoc -> SDoc
<+> forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas TyVar -> SDoc
pprTyVar [TyVar]
tidied_tvs
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in"
, SDoc
where_doc ]
; forall a. (TidyEnv, SDoc) -> TcM a
failWithTcM (TidyEnv
tidy_env2, Bool -> SDoc -> SDoc
pprWithExplicitKindsWhen Bool
True SDoc
doc) }
; String -> SDoc -> TcRn ()
traceTc String
"doNotQuantifyTyVars success" SDoc
empty }
promoteMetaTyVarTo :: TcLevel -> TcTyVar -> TcM Bool
promoteMetaTyVarTo :: TcLevel -> TyVar -> TcM Bool
promoteMetaTyVarTo TcLevel
tclvl TyVar
tv
| ASSERT2( isMetaTyVar tv, ppr tv )
TyVar -> TcLevel
tcTyVarLevel TyVar
tv TcLevel -> TcLevel -> Bool
`strictlyDeeperThan` TcLevel
tclvl
= do { TyVar
cloned_tv <- TyVar -> TcM TyVar
cloneMetaTyVar TyVar
tv
; let rhs_tv :: TyVar
rhs_tv = TyVar -> TcLevel -> TyVar
setMetaTyVarTcLevel TyVar
cloned_tv TcLevel
tclvl
; TyVar -> Kind -> TcRn ()
writeMetaTyVar TyVar
tv (TyVar -> Kind
mkTyVarTy TyVar
rhs_tv)
; String -> SDoc -> TcRn ()
traceTc String
"promoteTyVar" (forall a. Outputable a => a -> SDoc
ppr TyVar
tv SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"-->" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyVar
rhs_tv)
; forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
promoteTyVarSet :: TcTyVarSet -> TcM Bool
promoteTyVarSet :: CoVarSet -> TcM Bool
promoteTyVarSet CoVarSet
tvs
= do { TcLevel
tclvl <- TcM TcLevel
getTcLevel
; [Bool]
bools <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TcLevel -> TyVar -> TcM Bool
promoteMetaTyVarTo TcLevel
tclvl) forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
filter TyVar -> Bool
isPromotableMetaTyVar forall a b. (a -> b) -> a -> b
$
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet CoVarSet
tvs
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
bools) }
zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet
zonkTcTypeAndFV :: Kind -> TcM DTyVarSet
zonkTcTypeAndFV Kind
ty
= Kind -> DTyVarSet
tyCoVarsOfTypeDSet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Kind -> TcM Kind
zonkTcType Kind
ty
zonkTyCoVar :: TyCoVar -> TcM TcType
zonkTyCoVar :: TyVar -> TcM Kind
zonkTyCoVar TyVar
tv | TyVar -> Bool
isTcTyVar TyVar
tv = TyVar -> TcM Kind
zonkTcTyVar TyVar
tv
| TyVar -> Bool
isTyVar TyVar
tv = TyVar -> Kind
mkTyVarTy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> TcM TyVar
zonkTyCoVarKind TyVar
tv
| Bool
otherwise = ASSERT2( isCoVar tv, ppr tv )
Coercion -> Kind
mkCoercionTy forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Coercion
mkCoVarCo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> TcM TyVar
zonkTyCoVarKind TyVar
tv
zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet
zonkTyCoVarsAndFV :: CoVarSet -> TcM CoVarSet
zonkTyCoVarsAndFV CoVarSet
tycovars
= [Kind] -> CoVarSet
tyCoVarsOfTypes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> TcM Kind
zonkTyCoVar (forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet CoVarSet
tycovars)
zonkDTyCoVarSetAndFV :: DTyCoVarSet -> TcM DTyCoVarSet
zonkDTyCoVarSetAndFV :: DTyVarSet -> TcM DTyVarSet
zonkDTyCoVarSetAndFV DTyVarSet
tycovars
= [TyVar] -> DTyVarSet
mkDVarSet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TyVar] -> TcM [TyVar]
zonkTyCoVarsAndFVList forall a b. (a -> b) -> a -> b
$ DTyVarSet -> [TyVar]
dVarSetElems DTyVarSet
tycovars)
zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar]
zonkTyCoVarsAndFVList :: [TyVar] -> TcM [TyVar]
zonkTyCoVarsAndFVList [TyVar]
tycovars
= [Kind] -> [TyVar]
tyCoVarsOfTypesList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> TcM Kind
zonkTyCoVar [TyVar]
tycovars
zonkTcTyVars :: [TcTyVar] -> TcM [TcType]
zonkTcTyVars :: [TyVar] -> TcM [Kind]
zonkTcTyVars [TyVar]
tyvars = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> TcM Kind
zonkTcTyVar [TyVar]
tyvars
zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar
zonkTyCoVarKind :: TyVar -> TcM TyVar
zonkTyCoVarKind TyVar
tv = do { Kind
kind' <- Kind -> TcM Kind
zonkTcType (TyVar -> Kind
tyVarKind TyVar
tv)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Kind -> TyVar
setTyVarKind TyVar
tv Kind
kind') }
zonkTyCoVarKindBinder :: (VarBndr TyCoVar fl) -> TcM (VarBndr TyCoVar fl)
zonkTyCoVarKindBinder :: forall fl. VarBndr TyVar fl -> TcM (VarBndr TyVar fl)
zonkTyCoVarKindBinder (Bndr TyVar
tv fl
fl) = do { Kind
kind' <- Kind -> TcM Kind
zonkTcType (TyVar -> Kind
tyVarKind TyVar
tv)
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall var argf. var -> argf -> VarBndr var argf
Bndr (TyVar -> Kind -> TyVar
setTyVarKind TyVar
tv Kind
kind') fl
fl }
zonkImplication :: Implication -> TcM Implication
zonkImplication :: Implication -> TcM Implication
zonkImplication implic :: Implication
implic@(Implic { ic_skols :: Implication -> [TyVar]
ic_skols = [TyVar]
skols
, ic_given :: Implication -> [TyVar]
ic_given = [TyVar]
given
, ic_wanted :: Implication -> WantedConstraints
ic_wanted = WantedConstraints
wanted
, ic_info :: Implication -> SkolemInfo
ic_info = SkolemInfo
info })
= do { [TyVar]
skols' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> TcM TyVar
zonkTyCoVarKind [TyVar]
skols
; [TyVar]
given' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> TcM TyVar
zonkEvVar [TyVar]
given
; SkolemInfo
info' <- SkolemInfo -> TcM SkolemInfo
zonkSkolemInfo SkolemInfo
info
; WantedConstraints
wanted' <- WantedConstraints -> TcM WantedConstraints
zonkWCRec WantedConstraints
wanted
; forall (m :: * -> *) a. Monad m => a -> m a
return (Implication
implic { ic_skols :: [TyVar]
ic_skols = [TyVar]
skols'
, ic_given :: [TyVar]
ic_given = [TyVar]
given'
, ic_wanted :: WantedConstraints
ic_wanted = WantedConstraints
wanted'
, ic_info :: SkolemInfo
ic_info = SkolemInfo
info' }) }
zonkEvVar :: EvVar -> TcM EvVar
zonkEvVar :: TyVar -> TcM TyVar
zonkEvVar TyVar
var = forall (m :: * -> *).
Monad m =>
(Kind -> m Kind) -> TyVar -> m TyVar
updateIdTypeAndMultM Kind -> TcM Kind
zonkTcType TyVar
var
zonkWC :: WantedConstraints -> TcM WantedConstraints
zonkWC :: WantedConstraints -> TcM WantedConstraints
zonkWC WantedConstraints
wc = WantedConstraints -> TcM WantedConstraints
zonkWCRec WantedConstraints
wc
zonkWCRec :: WantedConstraints -> TcM WantedConstraints
zonkWCRec :: WantedConstraints -> TcM WantedConstraints
zonkWCRec (WC { wc_simple :: WantedConstraints -> Bag Ct
wc_simple = Bag Ct
simple, wc_impl :: WantedConstraints -> Bag Implication
wc_impl = Bag Implication
implic, wc_holes :: WantedConstraints -> Bag Hole
wc_holes = Bag Hole
holes })
= do { Bag Ct
simple' <- Bag Ct -> TcM (Bag Ct)
zonkSimples Bag Ct
simple
; Bag Implication
implic' <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM Implication -> TcM Implication
zonkImplication Bag Implication
implic
; Bag Hole
holes' <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM Hole -> TcM Hole
zonkHole Bag Hole
holes
; forall (m :: * -> *) a. Monad m => a -> m a
return (WC { wc_simple :: Bag Ct
wc_simple = Bag Ct
simple', wc_impl :: Bag Implication
wc_impl = Bag Implication
implic', wc_holes :: Bag Hole
wc_holes = Bag Hole
holes' }) }
zonkSimples :: Cts -> TcM Cts
zonkSimples :: Bag Ct -> TcM (Bag Ct)
zonkSimples Bag Ct
cts = do { Bag Ct
cts' <- forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM Ct -> TcM Ct
zonkCt Bag Ct
cts
; String -> SDoc -> TcRn ()
traceTc String
"zonkSimples done:" (forall a. Outputable a => a -> SDoc
ppr Bag Ct
cts')
; forall (m :: * -> *) a. Monad m => a -> m a
return Bag Ct
cts' }
zonkHole :: Hole -> TcM Hole
zonkHole :: Hole -> TcM Hole
zonkHole hole :: Hole
hole@(Hole { hole_ty :: Hole -> Kind
hole_ty = Kind
ty })
= do { Kind
ty' <- Kind -> TcM Kind
zonkTcType Kind
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (Hole
hole { hole_ty :: Kind
hole_ty = Kind
ty' }) }
zonkCt :: Ct -> TcM Ct
zonkCt :: Ct -> TcM Ct
zonkCt ct :: Ct
ct@(CDictCan { cc_ev :: Ct -> CtEvidence
cc_ev = CtEvidence
ev, cc_tyargs :: Ct -> [Kind]
cc_tyargs = [Kind]
args })
= do { CtEvidence
ev' <- CtEvidence -> TcM CtEvidence
zonkCtEvidence CtEvidence
ev
; [Kind]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Kind -> TcM Kind
zonkTcType [Kind]
args
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Ct
ct { cc_ev :: CtEvidence
cc_ev = CtEvidence
ev', cc_tyargs :: [Kind]
cc_tyargs = [Kind]
args' } }
zonkCt (CEqCan { cc_ev :: Ct -> CtEvidence
cc_ev = CtEvidence
ev })
= CtEvidence -> Ct
mkNonCanonical forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CtEvidence -> TcM CtEvidence
zonkCtEvidence CtEvidence
ev
zonkCt ct :: Ct
ct@(CIrredCan { cc_ev :: Ct -> CtEvidence
cc_ev = CtEvidence
ev })
= do { CtEvidence
ev' <- CtEvidence -> TcM CtEvidence
zonkCtEvidence CtEvidence
ev
; forall (m :: * -> *) a. Monad m => a -> m a
return (Ct
ct { cc_ev :: CtEvidence
cc_ev = CtEvidence
ev' }) }
zonkCt Ct
ct
= do { CtEvidence
fl' <- CtEvidence -> TcM CtEvidence
zonkCtEvidence (Ct -> CtEvidence
ctEvidence Ct
ct)
; forall (m :: * -> *) a. Monad m => a -> m a
return (CtEvidence -> Ct
mkNonCanonical CtEvidence
fl') }
zonkCtEvidence :: CtEvidence -> TcM CtEvidence
zonkCtEvidence :: CtEvidence -> TcM CtEvidence
zonkCtEvidence ctev :: CtEvidence
ctev@(CtGiven { ctev_pred :: CtEvidence -> Kind
ctev_pred = Kind
pred })
= do { Kind
pred' <- Kind -> TcM Kind
zonkTcType Kind
pred
; forall (m :: * -> *) a. Monad m => a -> m a
return (CtEvidence
ctev { ctev_pred :: Kind
ctev_pred = Kind
pred'}) }
zonkCtEvidence ctev :: CtEvidence
ctev@(CtWanted { ctev_pred :: CtEvidence -> Kind
ctev_pred = Kind
pred, ctev_dest :: CtEvidence -> TcEvDest
ctev_dest = TcEvDest
dest })
= do { Kind
pred' <- Kind -> TcM Kind
zonkTcType Kind
pred
; let dest' :: TcEvDest
dest' = case TcEvDest
dest of
EvVarDest TyVar
ev -> TyVar -> TcEvDest
EvVarDest forall a b. (a -> b) -> a -> b
$ TyVar -> Kind -> TyVar
setVarType TyVar
ev Kind
pred'
HoleDest CoercionHole
h -> CoercionHole -> TcEvDest
HoleDest CoercionHole
h
; forall (m :: * -> *) a. Monad m => a -> m a
return (CtEvidence
ctev { ctev_pred :: Kind
ctev_pred = Kind
pred', ctev_dest :: TcEvDest
ctev_dest = TcEvDest
dest' }) }
zonkCtEvidence ctev :: CtEvidence
ctev@(CtDerived { ctev_pred :: CtEvidence -> Kind
ctev_pred = Kind
pred })
= do { Kind
pred' <- Kind -> TcM Kind
zonkTcType Kind
pred
; forall (m :: * -> *) a. Monad m => a -> m a
return (CtEvidence
ctev { ctev_pred :: Kind
ctev_pred = Kind
pred' }) }
zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo
zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo
zonkSkolemInfo (SigSkol UserTypeCtxt
cx Kind
ty [(Name, TyVar)]
tv_prs) = do { Kind
ty' <- Kind -> TcM Kind
zonkTcType Kind
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (UserTypeCtxt -> Kind -> [(Name, TyVar)] -> SkolemInfo
SigSkol UserTypeCtxt
cx Kind
ty' [(Name, TyVar)]
tv_prs) }
zonkSkolemInfo (InferSkol [(Name, Kind)]
ntys) = do { [(Name, Kind)]
ntys' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}. (a, Kind) -> IOEnv (Env TcGblEnv TcLclEnv) (a, Kind)
do_one [(Name, Kind)]
ntys
; forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Kind)] -> SkolemInfo
InferSkol [(Name, Kind)]
ntys') }
where
do_one :: (a, Kind) -> IOEnv (Env TcGblEnv TcLclEnv) (a, Kind)
do_one (a
n, Kind
ty) = do { Kind
ty' <- Kind -> TcM Kind
zonkTcType Kind
ty; forall (m :: * -> *) a. Monad m => a -> m a
return (a
n, Kind
ty') }
zonkSkolemInfo SkolemInfo
skol_info = forall (m :: * -> *) a. Monad m => a -> m a
return SkolemInfo
skol_info
zonkTcType :: TcType -> TcM TcType
zonkTcTypes :: [TcType] -> TcM [TcType]
zonkCo :: Coercion -> TcM Coercion
(Kind -> TcM Kind
zonkTcType, [Kind] -> TcM [Kind]
zonkTcTypes, Coercion -> TcM Coercion
zonkCo, [Coercion] -> IOEnv (Env TcGblEnv TcLclEnv) [Coercion]
_)
= forall (m :: * -> *).
Monad m =>
TyCoMapper () m
-> (Kind -> m Kind, [Kind] -> m [Kind], Coercion -> m Coercion,
[Coercion] -> m [Coercion])
mapTyCo TyCoMapper () (IOEnv (Env TcGblEnv TcLclEnv))
zonkTcTypeMapper
zonkTcTypeMapper :: TyCoMapper () TcM
zonkTcTypeMapper :: TyCoMapper () (IOEnv (Env TcGblEnv TcLclEnv))
zonkTcTypeMapper = TyCoMapper
{ tcm_tyvar :: () -> TyVar -> TcM Kind
tcm_tyvar = forall a b. a -> b -> a
const TyVar -> TcM Kind
zonkTcTyVar
, tcm_covar :: () -> TyVar -> TcM Coercion
tcm_covar = forall a b. a -> b -> a
const (\TyVar
cv -> TyVar -> Coercion
mkCoVarCo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> TcM TyVar
zonkTyCoVarKind TyVar
cv)
, tcm_hole :: () -> CoercionHole -> TcM Coercion
tcm_hole = () -> CoercionHole -> TcM Coercion
hole
, tcm_tycobinder :: () -> TyVar -> ArgFlag -> IOEnv (Env TcGblEnv TcLclEnv) ((), TyVar)
tcm_tycobinder = \()
_env TyVar
tv ArgFlag
_vis -> ((), ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVar -> TcM TyVar
zonkTyCoVarKind TyVar
tv
, tcm_tycon :: TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
tcm_tycon = TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
zonkTcTyCon }
where
hole :: () -> CoercionHole -> TcM Coercion
hole :: () -> CoercionHole -> TcM Coercion
hole ()
_ hole :: CoercionHole
hole@(CoercionHole { ch_ref :: CoercionHole -> IORef (Maybe Coercion)
ch_ref = IORef (Maybe Coercion)
ref, ch_co_var :: CoercionHole -> TyVar
ch_co_var = TyVar
cv })
= do { Maybe Coercion
contents <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Maybe Coercion)
ref
; case Maybe Coercion
contents of
Just Coercion
co -> do { Coercion
co' <- Coercion -> TcM Coercion
zonkCo Coercion
co
; TyVar -> Coercion -> TcM Coercion
checkCoercionHole TyVar
cv Coercion
co' }
Maybe Coercion
Nothing -> do { TyVar
cv' <- TyVar -> TcM TyVar
zonkCoVar TyVar
cv
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CoercionHole -> Coercion
HoleCo (CoercionHole
hole { ch_co_var :: TyVar
ch_co_var = TyVar
cv' }) } }
zonkTcTyCon :: TcTyCon -> TcM TcTyCon
zonkTcTyCon :: TyCon -> IOEnv (Env TcGblEnv TcLclEnv) TyCon
zonkTcTyCon TyCon
tc
| TyCon -> Bool
tcTyConIsPoly TyCon
tc = forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc
| Bool
otherwise = do { Kind
tck' <- Kind -> TcM Kind
zonkTcType (TyCon -> Kind
tyConKind TyCon
tc)
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Kind -> TyCon
setTcTyConKind TyCon
tc Kind
tck') }
zonkTcTyVar :: TcTyVar -> TcM TcType
zonkTcTyVar :: TyVar -> TcM Kind
zonkTcTyVar TyVar
tv
| TyVar -> Bool
isTcTyVar TyVar
tv
= case TyVar -> TcTyVarDetails
tcTyVarDetails TyVar
tv of
SkolemTv {} -> TcM Kind
zonk_kind_and_return
RuntimeUnk {} -> TcM Kind
zonk_kind_and_return
MetaTv { mtv_ref :: TcTyVarDetails -> IORef MetaDetails
mtv_ref = IORef MetaDetails
ref }
-> do { MetaDetails
cts <- forall a env. IORef a -> IOEnv env a
readMutVar IORef MetaDetails
ref
; case MetaDetails
cts of
MetaDetails
Flexi -> TcM Kind
zonk_kind_and_return
Indirect Kind
ty -> do { Kind
zty <- Kind -> TcM Kind
zonkTcType Kind
ty
; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef MetaDetails
ref (Kind -> MetaDetails
Indirect Kind
zty)
; forall (m :: * -> *) a. Monad m => a -> m a
return Kind
zty } }
| Bool
otherwise
= TcM Kind
zonk_kind_and_return
where
zonk_kind_and_return :: TcM Kind
zonk_kind_and_return = do { TyVar
z_tv <- TyVar -> TcM TyVar
zonkTyCoVarKind TyVar
tv
; forall (m :: * -> *) a. Monad m => a -> m a
return (TyVar -> Kind
mkTyVarTy TyVar
z_tv) }
zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar
zonkTcTyVarToTyVar :: HasDebugCallStack => TyVar -> TcM TyVar
zonkTcTyVarToTyVar TyVar
tv
= do { Kind
ty <- TyVar -> TcM Kind
zonkTcTyVar TyVar
tv
; let tv' :: TyVar
tv' = case Kind -> Maybe TyVar
tcGetTyVar_maybe Kind
ty of
Just TyVar
tv' -> TyVar
tv'
Maybe TyVar
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"zonkTcTyVarToTyVar"
(forall a. Outputable a => a -> SDoc
ppr TyVar
tv SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Kind
ty)
; forall (m :: * -> *) a. Monad m => a -> m a
return TyVar
tv' }
zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TyVar spec)
zonkInvisTVBinder :: forall fl. VarBndr TyVar fl -> TcM (VarBndr TyVar fl)
zonkInvisTVBinder (Bndr TyVar
tv spec
spec) = do { TyVar
tv' <- HasDebugCallStack => TyVar -> TcM TyVar
zonkTcTyVarToTyVar TyVar
tv
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv' spec
spec) }
zonkId :: TcId -> TcM TcId
zonkId :: TyVar -> TcM TyVar
zonkId TyVar
id = forall (m :: * -> *).
Monad m =>
(Kind -> m Kind) -> TyVar -> m TyVar
Id.updateIdTypeAndMultM Kind -> TcM Kind
zonkTcType TyVar
id
zonkCoVar :: CoVar -> TcM CoVar
zonkCoVar :: TyVar -> TcM TyVar
zonkCoVar = TyVar -> TcM TyVar
zonkId
zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
zonkTidyTcType :: TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
env Kind
ty = do { Kind
ty' <- Kind -> TcM Kind
zonkTcType Kind
ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv -> Kind -> (TidyEnv, Kind)
tidyOpenType TidyEnv
env Kind
ty') }
zonkTidyTcTypes :: TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType])
zonkTidyTcTypes :: TidyEnv -> [Kind] -> TcM (TidyEnv, [Kind])
zonkTidyTcTypes = [Kind] -> TidyEnv -> [Kind] -> TcM (TidyEnv, [Kind])
zonkTidyTcTypes' []
where zonkTidyTcTypes' :: [Kind] -> TidyEnv -> [Kind] -> TcM (TidyEnv, [Kind])
zonkTidyTcTypes' [Kind]
zs TidyEnv
env [] = forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, forall a. [a] -> [a]
reverse [Kind]
zs)
zonkTidyTcTypes' [Kind]
zs TidyEnv
env (Kind
ty:[Kind]
tys)
= do { (TidyEnv
env', Kind
ty') <- TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
env Kind
ty
; [Kind] -> TidyEnv -> [Kind] -> TcM (TidyEnv, [Kind])
zonkTidyTcTypes' (Kind
ty'forall a. a -> [a] -> [a]
:[Kind]
zs) TidyEnv
env' [Kind]
tys }
zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)
zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)
zonkTidyOrigin TidyEnv
env (GivenOrigin SkolemInfo
skol_info)
= do { SkolemInfo
skol_info1 <- SkolemInfo -> TcM SkolemInfo
zonkSkolemInfo SkolemInfo
skol_info
; let skol_info2 :: SkolemInfo
skol_info2 = TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo TidyEnv
env SkolemInfo
skol_info1
; forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, SkolemInfo -> CtOrigin
GivenOrigin SkolemInfo
skol_info2) }
zonkTidyOrigin TidyEnv
env (OtherSCOrigin Int
sc_depth SkolemInfo
skol_info)
= do { SkolemInfo
skol_info1 <- SkolemInfo -> TcM SkolemInfo
zonkSkolemInfo SkolemInfo
skol_info
; let skol_info2 :: SkolemInfo
skol_info2 = TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo TidyEnv
env SkolemInfo
skol_info1
; forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, Int -> SkolemInfo -> CtOrigin
OtherSCOrigin Int
sc_depth SkolemInfo
skol_info2) }
zonkTidyOrigin TidyEnv
env orig :: CtOrigin
orig@(TypeEqOrigin { uo_actual :: CtOrigin -> Kind
uo_actual = Kind
act
, uo_expected :: CtOrigin -> Kind
uo_expected = Kind
exp })
= do { (TidyEnv
env1, Kind
act') <- TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
env Kind
act
; (TidyEnv
env2, Kind
exp') <- TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
env1 Kind
exp
; forall (m :: * -> *) a. Monad m => a -> m a
return ( TidyEnv
env2, CtOrigin
orig { uo_actual :: Kind
uo_actual = Kind
act'
, uo_expected :: Kind
uo_expected = Kind
exp' }) }
zonkTidyOrigin TidyEnv
env (KindEqOrigin Kind
ty1 Kind
ty2 CtOrigin
orig Maybe TypeOrKind
t_or_k)
= do { (TidyEnv
env1, Kind
ty1') <- TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
env Kind
ty1
; (TidyEnv
env2, Kind
ty2') <- TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
env1 Kind
ty2
; (TidyEnv
env3, CtOrigin
orig') <- TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)
zonkTidyOrigin TidyEnv
env2 CtOrigin
orig
; forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env3, Kind -> Kind -> CtOrigin -> Maybe TypeOrKind -> CtOrigin
KindEqOrigin Kind
ty1' Kind
ty2' CtOrigin
orig' Maybe TypeOrKind
t_or_k) }
zonkTidyOrigin TidyEnv
env (FunDepOrigin1 Kind
p1 CtOrigin
o1 RealSrcSpan
l1 Kind
p2 CtOrigin
o2 RealSrcSpan
l2)
= do { (TidyEnv
env1, Kind
p1') <- TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
env Kind
p1
; (TidyEnv
env2, Kind
p2') <- TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
env1 Kind
p2
; forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env2, Kind
-> CtOrigin
-> RealSrcSpan
-> Kind
-> CtOrigin
-> RealSrcSpan
-> CtOrigin
FunDepOrigin1 Kind
p1' CtOrigin
o1 RealSrcSpan
l1 Kind
p2' CtOrigin
o2 RealSrcSpan
l2) }
zonkTidyOrigin TidyEnv
env (FunDepOrigin2 Kind
p1 CtOrigin
o1 Kind
p2 SrcSpan
l2)
= do { (TidyEnv
env1, Kind
p1') <- TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
env Kind
p1
; (TidyEnv
env2, Kind
p2') <- TidyEnv -> Kind -> TcM (TidyEnv, Kind)
zonkTidyTcType TidyEnv
env1 Kind
p2
; (TidyEnv
env3, CtOrigin
o1') <- TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)
zonkTidyOrigin TidyEnv
env2 CtOrigin
o1
; forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env3, Kind -> CtOrigin -> Kind -> SrcSpan -> CtOrigin
FunDepOrigin2 Kind
p1' CtOrigin
o1' Kind
p2' SrcSpan
l2) }
zonkTidyOrigin TidyEnv
env CtOrigin
orig = forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, CtOrigin
orig)
tidyCt :: TidyEnv -> Ct -> Ct
tidyCt :: TidyEnv -> Ct -> Ct
tidyCt TidyEnv
env Ct
ct
= Ct
ct { cc_ev :: CtEvidence
cc_ev = CtEvidence -> CtEvidence
tidy_ev (Ct -> CtEvidence
ctEvidence Ct
ct) }
where
tidy_ev :: CtEvidence -> CtEvidence
tidy_ev :: CtEvidence -> CtEvidence
tidy_ev CtEvidence
ctev = CtEvidence
ctev { ctev_pred :: Kind
ctev_pred = TidyEnv -> Kind -> Kind
tidyType TidyEnv
env (CtEvidence -> Kind
ctev_pred CtEvidence
ctev) }
tidyHole :: TidyEnv -> Hole -> Hole
tidyHole :: TidyEnv -> Hole -> Hole
tidyHole TidyEnv
env h :: Hole
h@(Hole { hole_ty :: Hole -> Kind
hole_ty = Kind
ty }) = Hole
h { hole_ty :: Kind
hole_ty = TidyEnv -> Kind -> Kind
tidyType TidyEnv
env Kind
ty }
tidyEvVar :: TidyEnv -> EvVar -> EvVar
tidyEvVar :: TidyEnv -> TyVar -> TyVar
tidyEvVar TidyEnv
env TyVar
var = (Kind -> Kind) -> TyVar -> TyVar
updateIdTypeAndMult (TidyEnv -> Kind -> Kind
tidyType TidyEnv
env) TyVar
var
tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo TidyEnv
env (DerivSkol Kind
ty) = Kind -> SkolemInfo
DerivSkol (TidyEnv -> Kind -> Kind
tidyType TidyEnv
env Kind
ty)
tidySkolemInfo TidyEnv
env (SigSkol UserTypeCtxt
cx Kind
ty [(Name, TyVar)]
tv_prs) = TidyEnv -> UserTypeCtxt -> Kind -> [(Name, TyVar)] -> SkolemInfo
tidySigSkol TidyEnv
env UserTypeCtxt
cx Kind
ty [(Name, TyVar)]
tv_prs
tidySkolemInfo TidyEnv
env (InferSkol [(Name, Kind)]
ids) = [(Name, Kind)] -> SkolemInfo
InferSkol (forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd (TidyEnv -> Kind -> Kind
tidyType TidyEnv
env) [(Name, Kind)]
ids)
tidySkolemInfo TidyEnv
env (UnifyForAllSkol Kind
ty) = Kind -> SkolemInfo
UnifyForAllSkol (TidyEnv -> Kind -> Kind
tidyType TidyEnv
env Kind
ty)
tidySkolemInfo TidyEnv
_ SkolemInfo
info = SkolemInfo
info
tidySigSkol :: TidyEnv -> UserTypeCtxt
-> TcType -> [(Name,TcTyVar)] -> SkolemInfo
tidySigSkol :: TidyEnv -> UserTypeCtxt -> Kind -> [(Name, TyVar)] -> SkolemInfo
tidySigSkol TidyEnv
env UserTypeCtxt
cx Kind
ty [(Name, TyVar)]
tv_prs
= UserTypeCtxt -> Kind -> [(Name, TyVar)] -> SkolemInfo
SigSkol UserTypeCtxt
cx (TidyEnv -> Kind -> Kind
tidy_ty TidyEnv
env Kind
ty) [(Name, TyVar)]
tv_prs'
where
tv_prs' :: [(Name, TyVar)]
tv_prs' = forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd (TidyEnv -> TyVar -> TyVar
tidyTyCoVarOcc TidyEnv
env) [(Name, TyVar)]
tv_prs
inst_env :: NameEnv TyVar
inst_env = forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name, TyVar)]
tv_prs'
tidy_ty :: TidyEnv -> Kind -> Kind
tidy_ty TidyEnv
env (ForAllTy (Bndr TyVar
tv ArgFlag
vis) Kind
ty)
= VarBndr TyVar ArgFlag -> Kind -> Kind
ForAllTy (forall var argf. var -> argf -> VarBndr var argf
Bndr TyVar
tv' ArgFlag
vis) (TidyEnv -> Kind -> Kind
tidy_ty TidyEnv
env' Kind
ty)
where
(TidyEnv
env', TyVar
tv') = TidyEnv -> TyVar -> (TidyEnv, TyVar)
tidy_tv_bndr TidyEnv
env TyVar
tv
tidy_ty TidyEnv
env ty :: Kind
ty@(FunTy AnonArgFlag
InvisArg Kind
w Kind
arg Kind
res)
= Kind
ty { ft_mult :: Kind
ft_mult = TidyEnv -> Kind -> Kind
tidy_ty TidyEnv
env Kind
w,
ft_arg :: Kind
ft_arg = TidyEnv -> Kind -> Kind
tidyType TidyEnv
env Kind
arg,
ft_res :: Kind
ft_res = TidyEnv -> Kind -> Kind
tidy_ty TidyEnv
env Kind
res }
tidy_ty TidyEnv
env Kind
ty = TidyEnv -> Kind -> Kind
tidyType TidyEnv
env Kind
ty
tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
tidy_tv_bndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
tidy_tv_bndr env :: TidyEnv
env@(TidyOccEnv
occ_env, VarEnv TyVar
subst) TyVar
tv
| Just TyVar
tv' <- forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TyVar
inst_env (TyVar -> Name
tyVarName TyVar
tv)
= ((TidyOccEnv
occ_env, forall a. VarEnv a -> TyVar -> a -> VarEnv a
extendVarEnv VarEnv TyVar
subst TyVar
tv TyVar
tv'), TyVar
tv')
| Bool
otherwise
= TidyEnv -> TyVar -> (TidyEnv, TyVar)
tidyVarBndr TidyEnv
env TyVar
tv
ensureNotLevPoly :: Type
-> SDoc
-> TcM ()
ensureNotLevPoly :: Kind -> SDoc -> TcRn ()
ensureNotLevPoly Kind
ty SDoc
doc
= TcRn () -> TcRn ()
whenNoErrs forall a b. (a -> b) -> a -> b
$
SDoc -> Kind -> TcRn ()
checkForLevPoly SDoc
doc Kind
ty
checkForLevPoly :: SDoc -> Type -> TcM ()
checkForLevPoly :: SDoc -> Kind -> TcRn ()
checkForLevPoly = forall (m :: * -> *).
Monad m =>
(SDoc -> m ()) -> SDoc -> Kind -> m ()
checkForLevPolyX SDoc -> TcRn ()
addErr
checkForLevPolyX :: Monad m
=> (SDoc -> m ())
-> SDoc -> Type -> m ()
checkForLevPolyX :: forall (m :: * -> *).
Monad m =>
(SDoc -> m ()) -> SDoc -> Kind -> m ()
checkForLevPolyX SDoc -> m ()
add_err SDoc
extra Kind
ty
| Kind -> Bool
isTypeLevPoly Kind
ty
= SDoc -> m ()
add_err (Kind -> SDoc
formatLevPolyErr Kind
ty SDoc -> SDoc -> SDoc
$$ SDoc
extra)
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
formatLevPolyErr :: Type
-> SDoc
formatLevPolyErr :: Kind -> SDoc
formatLevPolyErr Kind
ty
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"A levity-polymorphic type is not allowed here:")
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Type:" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
pprWithTYPE Kind
tidy_ty
, String -> SDoc
text String
"Kind:" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
pprWithTYPE Kind
tidy_ki ])
where
(TidyEnv
tidy_env, Kind
tidy_ty) = TidyEnv -> Kind -> (TidyEnv, Kind)
tidyOpenType TidyEnv
emptyTidyEnv Kind
ty
tidy_ki :: Kind
tidy_ki = TidyEnv -> Kind -> Kind
tidyType TidyEnv
tidy_env (HasDebugCallStack => Kind -> Kind
tcTypeKind Kind
ty)
naughtyQuantification :: TcType
-> TcTyVar
-> TyVarSet
-> TcM a
naughtyQuantification :: forall a. Kind -> TyVar -> CoVarSet -> TcM a
naughtyQuantification Kind
orig_ty TyVar
tv CoVarSet
escapees
= do { Kind
orig_ty1 <- Kind -> TcM Kind
zonkTcType Kind
orig_ty
; [TyVar]
escapees' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM HasDebugCallStack => TyVar -> TcM TyVar
zonkTcTyVarToTyVar forall a b. (a -> b) -> a -> b
$
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet CoVarSet
escapees
; let fvs :: [TyVar]
fvs = Kind -> [TyVar]
tyCoVarsOfTypeWellScoped Kind
orig_ty1
env0 :: TidyEnv
env0 = TidyEnv -> [TyVar] -> TidyEnv
tidyFreeTyCoVars TidyEnv
emptyTidyEnv [TyVar]
fvs
env :: TidyEnv
env = TidyEnv
env0 TidyEnv -> [TyVar] -> TidyEnv
`delTidyEnvList` [TyVar]
escapees'
orig_ty' :: Kind
orig_ty' = TidyEnv -> Kind -> Kind
tidyType TidyEnv
env Kind
orig_ty1
ppr_tidied :: [TyVar] -> SDoc
ppr_tidied = [TyVar] -> SDoc
pprTyVars forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> TyVar -> TyVar
tidyTyCoVarOcc TidyEnv
env)
doc :: SDoc
doc = Bool -> SDoc -> SDoc
pprWithExplicitKindsWhen Bool
True forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Cannot generalise type; skolem" SDoc -> SDoc -> SDoc
<> forall a. [a] -> SDoc
plural [TyVar]
escapees'
, SDoc -> SDoc
quotes forall a b. (a -> b) -> a -> b
$ [TyVar] -> SDoc
ppr_tidied [TyVar]
escapees'
, String -> SDoc
text String
"would escape" SDoc -> SDoc -> SDoc
<+> forall a. [a] -> SDoc
itsOrTheir [TyVar]
escapees' SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"scope"
]
, [SDoc] -> SDoc
sep [ String -> SDoc
text String
"if I tried to quantify"
, [TyVar] -> SDoc
ppr_tidied [TyVar
tv]
, String -> SDoc
text String
"in this type:"
]
, Int -> SDoc -> SDoc
nest Int
2 (Kind -> SDoc
pprTidiedType Kind
orig_ty')
, String -> SDoc
text String
"(Indeed, I sometimes struggle even printing this correctly,"
, String -> SDoc
text String
" due to its ill-scoped nature.)"
]
; forall a. (TidyEnv, SDoc) -> TcM a
failWithTcM (TidyEnv
env, SDoc
doc) }