Commit 68278382 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Make a smart mkAppTyM

This patch finally delivers on Trac #15952.  Specifically

* Completely remove Note [The tcType invariant], along with
  its complicated consequences (IT1-IT6).

* Replace Note [The well-kinded type invariant] with:

      Note [The Purely Kinded Type Invariant (PKTI)]

* Instead, establish the (PKTI) in TcHsType.tcInferApps,
  by using a new function mkAppTyM when building a type
  application.  See Note [mkAppTyM].

* As a result we can remove the delicate mkNakedXX functions
  entirely.  Specifically, mkNakedCastTy retained lots of
  extremly delicate Refl coercions which just cluttered
  everything up, and(worse) were very vulnerable to being
  silently eliminated by (say) substTy. This led to a
  succession of bug reports.

The result is noticeably simpler to explain, simpler
to code, and Richard and I are much more confident that
it is correct.

It does not actually fix any bugs, but it brings us closer.
E.g. I hoped it'd fix #15918 and #15799, but it doesn't quite
do so.  However, it makes it much easier to fix.

I also did a raft of other minor refactorings:

* Use tcTypeKind consistently in the type checker

* Rename tcInstTyBinders to tcInvisibleTyBinders,
  and refactor it a bit

* Refactor tcEqType, pickyEqType, tcEqTypeVis
  Simpler, probably more efficient.

* Make zonkTcType zonk TcTyCons, at least if they have
  any free unification variables -- see zonk_tc_tycon
  in TcMType.zonkTcTypeMapper.

  Not zonking these TcTyCons was actually a bug before.

* Simplify try_to_reduce_no_cache in TcFlatten (a lot)

* Combine checkExpectedKind and checkExpectedKindX.
  And then combine the invisible-binder instantation code
  Much simpler now.

* Fix a little bug in TcMType.skolemiseQuantifiedTyVar.
  I'm not sure how I came across this originally.

* Fix a little bug in TyCoRep.isUnliftedRuntimeRep
  (the ASSERT was over-zealous).  Again I'm not certain
  how I encountered this.

* Add a missing solveLocalEqualities in
  TcHsType.tcHsPartialSigType.
  I came across this when trying to get level numbers
  right.
parent 19626218
...@@ -57,8 +57,7 @@ module HsTypes ( ...@@ -57,8 +57,7 @@ module HsTypes (
splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,
splitLHsPatSynTy, splitLHsPatSynTy,
splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy, splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
splitHsFunType, splitHsFunType, hsTyGetAppHead_maybe,
splitHsAppTys, hsTyGetAppHead_maybe,
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
ignoreParens, hsSigType, hsSigWcType, ignoreParens, hsSigType, hsSigWcType,
hsLTyVarBndrToType, hsLTyVarBndrsToTypes, hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
...@@ -1137,15 +1136,6 @@ The SrcSpan is the span of the original HsPar ...@@ -1137,15 +1136,6 @@ The SrcSpan is the span of the original HsPar
-} -}
splitHsAppTys :: HsType GhcRn -> (LHsType GhcRn, [LHsTypeArg GhcRn])
splitHsAppTys e = go (noLoc e) []
where
go :: LHsType GhcRn -> [LHsTypeArg GhcRn]
-> (LHsType GhcRn, [LHsTypeArg GhcRn])
go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as)
go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)
go (L sp (HsParTy _ f)) as = go f (HsArgPar sp : as)
go f as = (f,as)
-------------------------------- --------------------------------
splitLHsPatSynTy :: LHsType pass splitLHsPatSynTy :: LHsType pass
-> ( [LHsTyVarBndr pass] -- universals -> ( [LHsTyVarBndr pass] -- universals
......
...@@ -667,7 +667,7 @@ typeToLHsType ty ...@@ -667,7 +667,7 @@ typeToLHsType ty
| tyConAppNeedsKindSig True tc (length args) | tyConAppNeedsKindSig True tc (length args)
-- We must produce an explicit kind signature here to make certain -- We must produce an explicit kind signature here to make certain
-- programs kind-check. See Note [Kind signatures in typeToLHsType]. -- programs kind-check. See Note [Kind signatures in typeToLHsType].
= nlHsParTy $ noLoc $ HsKindSig NoExt lhs_ty (go (typeKind ty)) = nlHsParTy $ noLoc $ HsKindSig NoExt lhs_ty (go (tcTypeKind ty))
| otherwise = lhs_ty | otherwise = lhs_ty
where where
arg_flags :: [ArgFlag] arg_flags :: [ArgFlag]
......
...@@ -313,7 +313,7 @@ import NameSet ...@@ -313,7 +313,7 @@ import NameSet
import RdrName import RdrName
import HsSyn import HsSyn
import Type hiding( typeKind ) import Type hiding( typeKind )
import TcType hiding( typeKind ) import TcType
import Id import Id
import TysPrim ( alphaTyVars ) import TysPrim ( alphaTyVars )
import TyCon import TyCon
......
...@@ -60,7 +60,7 @@ import CoreFVs ( orphNamesOfFamInst ) ...@@ -60,7 +60,7 @@ import CoreFVs ( orphNamesOfFamInst )
import TyCon import TyCon
import Type hiding( typeKind ) import Type hiding( typeKind )
import RepType import RepType
import TcType hiding( typeKind ) import TcType
import Var import Var
import Id import Id
import Name hiding ( varName ) import Name hiding ( varName )
......
...@@ -15,7 +15,7 @@ module Inst ( ...@@ -15,7 +15,7 @@ module Inst (
instCall, instDFunType, instStupidTheta, instTyVarsWith, instCall, instDFunType, instStupidTheta, instTyVarsWith,
newWanted, newWanteds, newWanted, newWanteds,
tcInstTyBinders, tcInstTyBinder, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,
newOverloadedLit, mkOverLit, newOverloadedLit, mkOverLit,
...@@ -484,43 +484,34 @@ no longer cut it, but it seems fine for now. ...@@ -484,43 +484,34 @@ no longer cut it, but it seems fine for now.
-} -}
--------------------------- ---------------------------
-- | Instantantiate the TyConBinders of a forall type, -- | Instantiates up to n invisible binders
-- given its decomposed form (tvs, ty) -- Returns the instantiating types, and body kind
tcInstTyBinders :: HasDebugCallStack tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind)
=> ([TyCoBinder], TcKind) -- ^ The type (forall bs. ty)
-> TcM ([TcType], TcKind) -- ^ Instantiated bs, substituted ty tcInstInvisibleTyBinders 0 kind
-- Takes a pair because that is what splitPiTysInvisible returns = return ([], kind)
-- See also Note [Bidirectional type checking] tcInstInvisibleTyBinders n ty
tcInstTyBinders (bndrs, ty) = go n empty_subst ty
| null bndrs -- It's fine for bndrs to be empty e.g.
= return ([], ty) -- Check that (Maybe :: forall {k}. k->*),
-- and see the call to instTyBinders in checkExpectedKind
-- A user bug to be reported as such; it is not a compiler crash!
| otherwise
= do { (subst, args) <- mapAccumLM (tcInstTyBinder Nothing) empty_subst bndrs
; ty' <- zonkTcType (substTy subst ty)
-- Why zonk the result? So that tcTyVar can
-- obey (IT6) of Note [The tcType invariant] in TcHsType
-- ToDo: SLPJ: I don't think this is needed
; return (args, ty') }
where where
empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))
go n subst kind
| n > 0
, Just (bndr, body) <- tcSplitPiTy_maybe kind
, isInvisibleBinder bndr
= do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr
; (args, inner_ty) <- go (n-1) subst' body
; return (arg:args, inner_ty) }
| otherwise
= return ([], substTy subst kind)
-- | Used only in *types* -- | Used only in *types*
tcInstTyBinder :: Maybe (VarEnv Kind) tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
-> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) tcInstInvisibleTyBinder subst (Named (Bndr tv _))
tcInstTyBinder mb_kind_info subst (Named (Bndr tv _)) = do { (subst', tv') <- newMetaTyVarX subst tv
= case lookup_tv tv of ; return (subst', mkTyVarTy tv') }
Just ki -> return (extendTvSubstAndInScope subst tv ki, ki)
Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv
; return (subst', mkTyVarTy tv') }
where
lookup_tv tv = do { env <- mb_kind_info -- `Maybe` monad
; lookupVarEnv env tv }
tcInstTyBinder _ subst (Anon ty) tcInstInvisibleTyBinder subst (Anon ty)
-- This is the *only* constraint currently handled in types. -- This is the *only* constraint currently handled in types.
| Just (mk, k1, k2) <- get_eq_tys_maybe substed_ty | Just (mk, k1, k2) <- get_eq_tys_maybe substed_ty
= do { co <- unifyKind Nothing k1 k2 = do { co <- unifyKind Nothing k1 k2
......
...@@ -873,9 +873,9 @@ can_eq_nc' ...@@ -873,9 +873,9 @@ can_eq_nc'
-> TcS (StopOrContinue Ct) -> TcS (StopOrContinue Ct)
-- Expand synonyms first; see Note [Type synonyms and canonicalization] -- Expand synonyms first; see Note [Type synonyms and canonicalization]
can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
| Just ty1' <- tcView ty1 = can_eq_nc flat ev eq_rel ty1' ps_ty1 ty2 ps_ty2 | Just ty1' <- tcView ty1 = can_eq_nc' flat rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2
| Just ty2' <- tcView ty2 = can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2' ps_ty2 | Just ty2' <- tcView ty2 = can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2
-- need to check for reflexivity in the ReprEq case. -- need to check for reflexivity in the ReprEq case.
-- See Note [Eager reflexivity check] -- See Note [Eager reflexivity check]
...@@ -1048,7 +1048,7 @@ can_eq_nc_forall ev eq_rel s1 s2 ...@@ -1048,7 +1048,7 @@ can_eq_nc_forall ev eq_rel s1 s2
-- | Compare types for equality, while zonking as necessary. Gives up -- | Compare types for equality, while zonking as necessary. Gives up
-- as soon as it finds that two types are not equal. -- as soon as it finds that two types are not equal.
-- This is quite handy when some unification has made two -- This is quite handy when some unification has made two
-- types in an inert wanted to be equal. We can discover the equality without -- types in an inert Wanted to be equal. We can discover the equality without
-- flattening, which is sometimes very expensive (in the case of type functions). -- flattening, which is sometimes very expensive (in the case of type functions).
-- In particular, this function makes a ~20% improvement in test case -- In particular, this function makes a ~20% improvement in test case
-- perf/compiler/T5030. -- perf/compiler/T5030.
...@@ -1836,10 +1836,11 @@ canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2 ...@@ -1836,10 +1836,11 @@ canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
| k1 `tcEqType` k2 | k1 `tcEqType` k2
= canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2 = canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
-- Note [Flattening] in TcFlatten gives us (F2), which says that -- So the LHS and RHS don't have equal kinds
-- flattening is always homogeneous (doesn't change kinds). But -- Note [Flattening] in TcFlatten gives us (F2), which says that
-- perhaps by flattening the kinds of the two sides of the equality -- flattening is always homogeneous (doesn't change kinds). But
-- at hand makes them equal. So let's try that. -- perhaps by flattening the kinds of the two sides of the equality
-- at hand makes them equal. So let's try that.
| otherwise | otherwise
= do { (flat_k1, k1_co) <- flattenKind loc flav k1 -- k1_co :: flat_k1 ~N kind(xi1) = do { (flat_k1, k1_co) <- flattenKind loc flav k1 -- k1_co :: flat_k1 ~N kind(xi1)
; (flat_k2, k2_co) <- flattenKind loc flav k2 -- k2_co :: flat_k2 ~N kind(xi2) ; (flat_k2, k2_co) <- flattenKind loc flav k2 -- k2_co :: flat_k2 ~N kind(xi2)
...@@ -1852,7 +1853,7 @@ canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2 ...@@ -1852,7 +1853,7 @@ canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
, ppr flat_k2 , ppr flat_k2
, ppr k2_co ]) , ppr k2_co ])
-- we know the LHS is a tyvar. So let's dump all the coercions on the RHS -- We know the LHS is a tyvar. So let's dump all the coercions on the RHS
-- If flat_k1 == flat_k2, let's dump all the coercions on the RHS and -- If flat_k1 == flat_k2, let's dump all the coercions on the RHS and
-- then call canEqTyVarHomo. If they don't equal, just rewriteEqEvidence -- then call canEqTyVarHomo. If they don't equal, just rewriteEqEvidence
-- (as an optimization, so that we don't have to flatten the kinds again) -- (as an optimization, so that we don't have to flatten the kinds again)
...@@ -1934,7 +1935,7 @@ canEqTyVarHetero ev eq_rel tv1 co1 ki1 ps_tv1 xi2 ki2 ps_xi2 ...@@ -1934,7 +1935,7 @@ canEqTyVarHetero ev eq_rel tv1 co1 ki1 ps_tv1 xi2 ki2 ps_xi2
-- See Note [Equalities with incompatible kinds] -- See Note [Equalities with incompatible kinds]
| otherwise -- Wanted and Derived | otherwise -- Wanted and Derived
-- NB: all kind equalities are Nominal -- NB: all kind equalities are Nominal
= do { emitNewDerivedEq kind_loc Nominal ki1 ki2 = do { emitNewDerivedEq kind_loc Nominal ki1 ki2
-- kind_ev :: (ki1 :: *) ~ (ki2 :: *) -- kind_ev :: (ki1 :: *) ~ (ki2 :: *)
; traceTcS "Hetero equality gives rise to derived kind equality" $ ; traceTcS "Hetero equality gives rise to derived kind equality" $
......
...@@ -1975,17 +1975,16 @@ misMatchMsg ct oriented ty1 ty2 ...@@ -1975,17 +1975,16 @@ misMatchMsg ct oriented ty1 ty2
-- themselves. -- themselves.
pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin
-> SDoc -> SDoc -> SDoc -> SDoc
pprWithExplicitKindsWhenMismatch ty1 ty2 ct = pprWithExplicitKindsWhenMismatch ty1 ty2 ct
pprWithExplicitKindsWhen mismatch = pprWithExplicitKindsWhen show_kinds
where where
(act_ty, exp_ty) = case ct of (act_ty, exp_ty) = case ct of
TypeEqOrigin { uo_actual = act TypeEqOrigin { uo_actual = act
, uo_expected = exp } -> (act, exp) , uo_expected = exp } -> (act, exp)
_ -> (ty1, ty2) _ -> (ty1, ty2)
mismatch | Just vis <- tcEqTypeVis act_ty exp_ty show_kinds = tcEqTypeVis act_ty exp_ty
= not vis -- True when the visible bit of the types look the same,
| otherwise -- so we want to show the kinds in the displayed type
= False
mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool
-> (Bool, Maybe SwapFlag, SDoc) -> (Bool, Maybe SwapFlag, SDoc)
......
...@@ -1329,8 +1329,7 @@ flatten_exact_fam_app_fully tc tys ...@@ -1329,8 +1329,7 @@ flatten_exact_fam_app_fully tc tys
-- See Note [Reduce type family applications eagerly] -- See Note [Reduce type family applications eagerly]
-- the following tcTypeKind should never be evaluated, as it's just used in -- the following tcTypeKind should never be evaluated, as it's just used in
-- casting, and casts by refl are dropped -- casting, and casts by refl are dropped
= do { let reduce_co = mkNomReflCo (tcTypeKind (mkTyConApp tc tys)) = do { mOut <- try_to_reduce_nocache tc tys
; mOut <- try_to_reduce_nocache tc tys reduce_co id
; case mOut of ; case mOut of
Just out -> pure out Just out -> pure out
Nothing -> do Nothing -> do
...@@ -1452,16 +1451,8 @@ flatten_exact_fam_app_fully tc tys ...@@ -1452,16 +1451,8 @@ flatten_exact_fam_app_fully tc tys
try_to_reduce_nocache :: TyCon -- F, family tycon try_to_reduce_nocache :: TyCon -- F, family tycon
-> [Type] -- args, not necessarily flattened -> [Type] -- args, not necessarily flattened
-> CoercionN -- kind_co :: tcTypeKind(F args)
-- ~N tcTypeKind(F orig_args)
-- where
-- orig_args is what was passed to the
-- outer function
-> ( Coercion -- :: (xi |> kind_co) ~ F args
-> Coercion ) -- what to return from outer
-- function
-> FlatM (Maybe (Xi, Coercion)) -> FlatM (Maybe (Xi, Coercion))
try_to_reduce_nocache tc tys kind_co update_co try_to_reduce_nocache tc tys
= do { checkStackDepth (mkTyConApp tc tys) = do { checkStackDepth (mkTyConApp tc tys)
; mb_match <- liftTcS $ matchFam tc tys ; mb_match <- liftTcS $ matchFam tc tys
; case mb_match of ; case mb_match of
...@@ -1470,13 +1461,9 @@ flatten_exact_fam_app_fully tc tys ...@@ -1470,13 +1461,9 @@ flatten_exact_fam_app_fully tc tys
Just (norm_co, norm_ty) Just (norm_co, norm_ty)
-> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty
; eq_rel <- getEqRel ; eq_rel <- getEqRel
; let co = maybeSubCo eq_rel norm_co ; let co = mkSymCo (maybeSubCo eq_rel norm_co
`mkTransCo` mkSymCo final_co `mkTransCo` mkSymCo final_co)
role = eqRelRole eq_rel ; return $ Just (xi, co) }
xi' = xi `mkCastTy` kind_co
co' = update_co $
mkTcCoherenceLeftCo role xi kind_co (mkSymCo co)
; return $ Just (xi', co') }
Nothing -> pure Nothing } Nothing -> pure Nothing }
{- Note [Reduce type family applications eagerly] {- Note [Reduce type family applications eagerly]
......
...@@ -204,6 +204,7 @@ data ZonkEnv -- See Note [The ZonkEnv] ...@@ -204,6 +204,7 @@ data ZonkEnv -- See Note [The ZonkEnv]
, ze_tv_env :: TyCoVarEnv TyCoVar , ze_tv_env :: TyCoVarEnv TyCoVar
, ze_id_env :: IdEnv Id , ze_id_env :: IdEnv Id
, ze_meta_tv_env :: TcRef (TyVarEnv Type) } , ze_meta_tv_env :: TcRef (TyVarEnv Type) }
{- Note [The ZonkEnv] {- Note [The ZonkEnv]
~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~
* ze_flexi :: ZonkFlexi says what to do with a * ze_flexi :: ZonkFlexi says what to do with a
......
This diff is collapsed.
...@@ -794,12 +794,17 @@ tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksi ...@@ -794,12 +794,17 @@ tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksi
bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
do { stupid_theta <- tcHsContext hs_ctxt do { stupid_theta <- tcHsContext hs_ctxt
; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats
-- Ensure that the instance is consistent with its
-- parent class -- Ensure that the instance is consistent
-- with its parent class
; addConsistencyConstraints mb_clsinfo lhs_ty ; addConsistencyConstraints mb_clsinfo lhs_ty
-- Add constraints from the data constructors
; mapM_ (wrapLocM_ kcConDecl) hs_cons ; mapM_ (wrapLocM_ kcConDecl) hs_cons
-- Add constraints from the result signature
; res_kind <- tc_kind_sig m_ksig ; res_kind <- tc_kind_sig m_ksig
; lhs_ty <- checkExpectedKind YesSaturation pp_lhs lhs_ty lhs_kind res_kind ; lhs_ty <- checkExpectedKind_pp pp_lhs lhs_ty lhs_kind res_kind
; return (stupid_theta, lhs_ty, res_kind) } ; return (stupid_theta, lhs_ty, res_kind) }
-- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts] -- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts]
...@@ -894,7 +899,7 @@ There are several fiddly subtleties lurking here ...@@ -894,7 +899,7 @@ There are several fiddly subtleties lurking here
'k1' and 'k2', as well as 'b'. 'k1' and 'k2', as well as 'b'.
The skolemise bit is done in tc_kind_sig, while the instantiate bit The skolemise bit is done in tc_kind_sig, while the instantiate bit
is done by the checkExpectedKind that immediately follows. is done by tcFamTyPats.
* Very fiddly point. When we eta-reduce to * Very fiddly point. When we eta-reduce to
axiom AxDrep forall a b. D [(a,b]] = Drep a b axiom AxDrep forall a b. D [(a,b]] = Drep a b
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
Monadic type operations Monadic type operations
This module contains monadic operations over types that contain This module contains monadic operations over types that contain
mutable type variables mutable type variables.
-} -}
{-# LANGUAGE CPP, TupleSections, MultiWayIf #-} {-# LANGUAGE CPP, TupleSections, MultiWayIf #-}
...@@ -784,10 +784,8 @@ writeMetaTyVarRef tyvar ref ty ...@@ -784,10 +784,8 @@ writeMetaTyVarRef tyvar ref ty
= do { meta_details <- readMutVar ref; = do { meta_details <- readMutVar ref;
-- Zonk kinds to allow the error check to work -- Zonk kinds to allow the error check to work
; zonked_tv_kind <- zonkTcType tv_kind ; zonked_tv_kind <- zonkTcType tv_kind
; zonked_ty <- zonkTcType ty ; zonked_ty_kind <- zonkTcType ty_kind
; let zonked_ty_kind = tcTypeKind zonked_ty -- Need to zonk even before typeKind; ; let kind_check_ok = tcIsConstraintKind zonked_tv_kind
-- otherwise, we can panic in piResultTy
kind_check_ok = tcIsConstraintKind zonked_tv_kind
|| tcEqKind zonked_ty_kind zonked_tv_kind || tcEqKind zonked_ty_kind zonked_tv_kind
-- Hack alert! tcIsConstraintKind: see TcHsType -- Hack alert! tcIsConstraintKind: see TcHsType
-- Note [Extra-constraint holes in partial type signatures] -- Note [Extra-constraint holes in partial type signatures]
...@@ -813,6 +811,7 @@ writeMetaTyVarRef tyvar ref ty ...@@ -813,6 +811,7 @@ writeMetaTyVarRef tyvar ref ty
; writeMutVar ref (Indirect ty) } ; writeMutVar ref (Indirect ty) }
where where
tv_kind = tyVarKind tyvar tv_kind = tyVarKind tyvar
ty_kind = tcTypeKind ty
tv_lvl = tcTyVarLevel tyvar tv_lvl = tcTyVarLevel tyvar
ty_lvl = tcTypeLevel ty ty_lvl = tcTypeLevel ty
...@@ -1518,15 +1517,14 @@ defaultTyVar default_kind tv ...@@ -1518,15 +1517,14 @@ defaultTyVar default_kind tv
; writeMetaTyVar tv liftedRepTy ; writeMetaTyVar tv liftedRepTy
; return True } ; return True }
| default_kind -- -XNoPolyKinds and this is a kind var | default_kind -- -XNoPolyKinds and this is a kind var
= do { default_kind_var tv -- so default it to * if possible = default_kind_var tv -- so default it to * if possible
; return True }
| otherwise | otherwise
= return False = return False
where where
default_kind_var :: TyVar -> TcM () default_kind_var :: TyVar -> TcM Bool
-- defaultKindVar is used exclusively with -XNoPolyKinds -- defaultKindVar is used exclusively with -XNoPolyKinds
-- See Note [Defaulting with -XNoPolyKinds] -- See Note [Defaulting with -XNoPolyKinds]
-- It takes an (unconstrained) meta tyvar and defaults it. -- It takes an (unconstrained) meta tyvar and defaults it.
...@@ -1534,11 +1532,20 @@ defaultTyVar default_kind tv ...@@ -1534,11 +1532,20 @@ defaultTyVar default_kind tv
default_kind_var kv default_kind_var kv
| isLiftedTypeKind (tyVarKind kv) | isLiftedTypeKind (tyVarKind kv)
= do { traceTc "Defaulting a kind var to *" (ppr kv) = do { traceTc "Defaulting a kind var to *" (ppr kv)
; writeMetaTyVar kv liftedTypeKind } ; writeMetaTyVar kv liftedTypeKind
; return True }
| otherwise | otherwise
= addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv') = do { addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')
, text "of kind:" <+> ppr (tyVarKind kv') , text "of kind:" <+> ppr (tyVarKind kv')
, text "Perhaps enable PolyKinds or add a kind signature" ]) , text "Perhaps enable PolyKinds or add a kind signature" ])
-- We failed to default it, so return False to say so.
-- Hence, it'll get skolemised. That might seem odd, but we must either
-- promote, skolemise, or zap-to-Any, to satisfy TcHsType
-- Note [Recipe for checking a signature]
-- Otherwise we get level-number assertion failures. It doesn't matter much
-- because we are in an error siutation anyway.
; return False
}
where where
(_, kv') = tidyOpenTyCoVar emptyTidyEnv kv (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv
...@@ -1937,7 +1944,7 @@ zonkTcTypeMapper = TyCoMapper ...@@ -1937,7 +1944,7 @@ zonkTcTypeMapper = TyCoMapper
, tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv) , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv)
, tcm_hole = hole , tcm_hole = hole
, tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv
, tcm_tycon = return } , tcm_tycon = zonk_tc_tycon }
where where
hole :: () -> CoercionHole -> TcM Coercion hole :: () -> CoercionHole -> TcM Coercion
hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
...@@ -1948,6 +1955,12 @@ zonkTcTypeMapper = TyCoMapper ...@@ -1948,6 +1955,12 @@ zonkTcTypeMapper = TyCoMapper
Nothing -> do { cv' <- zonkCoVar cv Nothing -> do { cv' <- zonkCoVar cv
; return $ HoleCo (hole { ch_co_var = cv' }) } } ; return $ HoleCo (hole { ch_co_var = cv' }) } }
zonk_tc_tycon tc -- A non-poly TcTyCon may have unification
-- variables that need zonking, but poly ones cannot
| tcTyConIsPoly tc = return tc
| otherwise = do { tck' <- zonkTcType (tyConKind tc)
; return (setTcTyConKind tc tck') }
-- For unbound, mutable tyvars, zonkType uses the function given to it -- For unbound, mutable tyvars, zonkType uses the function given to it
-- For tyvars bound at a for-all, zonkType zonks them to an immutable -- For tyvars bound at a for-all, zonkType zonks them to an immutable
-- type variable and zonks the kind too -- type variable and zonks the kind too
......
...@@ -3401,10 +3401,8 @@ newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts ...@@ -3401,10 +3401,8 @@ newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts
emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion
-- | Emit a new Wanted equality into the work-list -- | Emit a new Wanted equality into the work-list
emitNewWantedEq loc role ty1 ty2 emitNewWantedEq loc role ty1 ty2
| otherwise
= do { (ev, co) <- newWantedEq loc role ty1 ty2 = do { (ev, co) <- newWantedEq loc role ty1 ty2
; updWorkListTcS $ ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))
extendWorkListEq (mkNonCanonical ev)
; return co } ; return co }
-- | Make a new equality CtEvidence -- | Make a new equality CtEvidence
......
...@@ -39,7 +39,6 @@ import {-# SOURCE #-} TcInstDcls( tcInstDecls1 ) ...@@ -39,7 +39,6 @@ import {-# SOURCE #-} TcInstDcls( tcInstDecls1 )
import TcDeriv (DerivInfo) import TcDeriv (DerivInfo)
import TcHsType import TcHsType
import ClsInst( AssocInstInfo(..) ) import ClsInst( AssocInstInfo(..) )
import Inst( tcInstTyBinders )
import TcMType import TcMType
import TysWiredIn ( unitTy ) import TysWiredIn ( unitTy )
import TcType import TcType
...@@ -1742,7 +1741,7 @@ kcTyFamInstEqn tc_fam_tc ...@@ -1742,7 +1741,7 @@ kcTyFamInstEqn tc_fam_tc
; discardResult $ ; discardResult $
bindImplicitTKBndrs_Q_Tv imp_vars $ bindImplicitTKBndrs_Q_Tv imp_vars $
bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $ bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $
do { (_, res_kind) <- tcFamTyPats tc_fam_tc hs_pats do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats
; tcCheckLHsType hs_rhs_ty res_kind } ; tcCheckLHsType hs_rhs_ty res_kind }
-- Why "_Tv" here? Consider (Trac #14066 -- Why "_Tv" here? Consider (Trac #14066
-- type family Bar x y where -- type family Bar x y where
...@@ -1870,7 +1869,7 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty ...@@ -1870,7 +1869,7 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
solveEqualities $ solveEqualities $
bindImplicitTKBndrs_Q_Skol imp_vars $ bindImplicitTKBndrs_Q_Skol imp_vars $
bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
do { (lhs_ty, rhs_kind) <- tc_lhs do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats
-- Ensure that the instance is consistent with its -- Ensure that the instance is consistent with its
-- parent class (#16008) -- parent class (#16008)
; addConsistencyConstraints mb_clsinfo lhs_ty ; addConsistencyConstraints mb_clsinfo lhs_ty
...@@ -1897,43 +1896,6 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty ...@@ -1897,43 +1896,6 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
-- have been solved before we attempt to unravel it -- have been solved before we attempt to unravel it
; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs) ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs)
; return (qtvs, pats, rhs_ty) } ; return (qtvs, pats, rhs_ty) }
where
tc_lhs | null hs_pats -- See Note [Apparently-nullary families]
= do { (args, rhs_kind) <- tcInstTyBinders $
splitPiTysInvisibleN (tyConArity fam_tc)
(tyConKind fam_tc)
; return (mkTyConApp fam_tc args, rhs_kind) }
| otherwise
= tcFamTyPats fam_tc hs_pats
{- Note [Apparently-nullary families]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
type family F :: k -> *
This really means
type family F @k :: k -> *
That is, the family has arity 1, and can match on the kind. So it's
not really a nullary family. NB that
type famly F2 :: forall k. k -> *
is quite different and really does have arity 0.
Returning to F we might have
type instannce F = Maybe
which instantaite 'k' to '*' and really means
type instannce F @* = Maybe
Conclusion: in this odd case where there are no LHS patterns, we
should instantiate any invisible foralls in F's kind, to saturate
its arity (but no more). This is what happens in tc_lhs in
tcTyFamInstEqnGuts.
If there are any visible patterns, then the first will force
instantiation of any Inferred quantifiers for F -- remember,
Inferred quantifiers always come first.
-}
----------------- -----------------
tcFamTyPats :: TyCon tcFamTyPats :: TyCon
...@@ -1942,9 +1904,7 @@ tcFamTyPats :: TyCon ...@@ -1942,9 +1904,7 @@ tcFamTyPats :: TyCon
-- Used for both type and data families -- Used for both type and data families
tcFamTyPats fam_tc hs_pats tcFamTyPats fam_tc hs_pats
= do { traceTc "tcFamTyPats {" $ = do { traceTc "tcFamTyPats {" $
vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]
, text "arity:" <+> ppr fam_arity
, text "kind:" <+> ppr fam_kind ]
; let fun_ty = mkTyConApp fam_tc [] ; let fun_ty = mkTyConApp fam_tc []
...@@ -1952,18 +1912,15 @@ tcFamTyPats fam_tc hs_pats ...@@ -1952,18 +1912,15 @@ tcFamTyPats fam_tc hs_pats
setXOptM LangExt.PartialTypeSignatures $ setXOptM LangExt.PartialTypeSignatures $
-- See Note [Wildcards in family instances] in -- See Note [Wildcards in family instances] in
-- RnSource.hs -- RnSource.hs
tcInferApps typeLevelMode lhs_fun fun_ty tcInferApps typeLevelMode lhs_fun fun_ty hs_pats
fam_kind hs_pats
; traceTc "End tcFamTyPats }" $ ; traceTc "End tcFamTyPats }" $
vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ]
, text "res_kind:" <+> ppr res_kind ]
; return (fam_app, res_kind) } ; return (fam_app, res_kind) }
where where
fam_name = tyConName fam_tc fam_name = tyConName fam_tc
fam_arity = tyConArity fam_tc fam_arity = tyConArity fam_tc
fam_kind = tyConKind fam_tc
lhs_fun = noLoc (HsTyVar noExt NotPromoted (noLoc fam_name)) lhs_fun = noLoc (HsTyVar noExt NotPromoted (noLoc fam_name))
unravelFamInstPats :: TcType -> [TcType] unravelFamInstPats :: TcType -> [TcType]
......
This diff is collapsed.
...@@ -790,7 +790,7 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected ...@@ -790,7 +790,7 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected
inst_and_unify = do { (wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual inst_and_unify = do { (wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual
-- if we haven't recurred through an arrow, then -- If we haven't recurred through an arrow, then
-- the eq_orig will list ty_actual. In this case, -- the eq_orig will list ty_actual. In this case,
-- we want to update the origin to reflect the -- we want to update the origin to reflect the
-- instantiation. If we *have* recurred through -- instantiation. If we *have* recurred through
...@@ -1450,12 +1450,12 @@ uType t_or_k origin orig_ty1 orig_ty2 ...@@ -1450,12 +1450,12 @@ uType t_or_k origin orig_ty1 orig_ty2
go (AppTy s1 t1) (TyConApp tc2 ts2) go (AppTy s1 t1) (TyConApp tc2 ts2)
| Just (ts2', t2') <- snocView ts2 | Just (ts2', t2') <- snocView ts2
= ASSERT( mightBeUnsaturatedTyCon tc2 ) = ASSERT( not (mustBeSaturated tc2) )
go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'