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 (
splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,
splitLHsPatSynTy,
splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy,
splitHsFunType,
splitHsAppTys, hsTyGetAppHead_maybe,
splitHsFunType, hsTyGetAppHead_maybe,
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
ignoreParens, hsSigType, hsSigWcType,
hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
......@@ -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
-> ( [LHsTyVarBndr pass] -- universals
......
......@@ -667,7 +667,7 @@ typeToLHsType ty
| tyConAppNeedsKindSig True tc (length args)
-- We must produce an explicit kind signature here to make certain
-- 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
where
arg_flags :: [ArgFlag]
......
......@@ -313,7 +313,7 @@ import NameSet
import RdrName
import HsSyn
import Type hiding( typeKind )
import TcType hiding( typeKind )
import TcType
import Id
import TysPrim ( alphaTyVars )
import TyCon
......
......@@ -60,7 +60,7 @@ import CoreFVs ( orphNamesOfFamInst )
import TyCon
import Type hiding( typeKind )
import RepType
import TcType hiding( typeKind )
import TcType
import Var
import Id
import Name hiding ( varName )
......
......@@ -15,7 +15,7 @@ module Inst (
instCall, instDFunType, instStupidTheta, instTyVarsWith,
newWanted, newWanteds,
tcInstTyBinders, tcInstTyBinder,
tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,
newOverloadedLit, mkOverLit,
......@@ -484,43 +484,34 @@ no longer cut it, but it seems fine for now.
-}
---------------------------
-- | Instantantiate the TyConBinders of a forall type,
-- given its decomposed form (tvs, ty)
tcInstTyBinders :: HasDebugCallStack
=> ([TyCoBinder], TcKind) -- ^ The type (forall bs. ty)
-> TcM ([TcType], TcKind) -- ^ Instantiated bs, substituted ty
-- Takes a pair because that is what splitPiTysInvisible returns
-- See also Note [Bidirectional type checking]
tcInstTyBinders (bndrs, 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') }
-- | Instantiates up to n invisible binders
-- Returns the instantiating types, and body kind
tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind)
tcInstInvisibleTyBinders 0 kind
= return ([], kind)
tcInstInvisibleTyBinders n ty
= go n empty_subst ty
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*
tcInstTyBinder :: Maybe (VarEnv Kind)
-> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
tcInstTyBinder mb_kind_info subst (Named (Bndr tv _))
= case lookup_tv tv of
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 }
tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
tcInstInvisibleTyBinder subst (Named (Bndr tv _))
= do { (subst', tv') <- newMetaTyVarX subst tv
; return (subst', mkTyVarTy tv') }
tcInstTyBinder _ subst (Anon ty)
tcInstInvisibleTyBinder subst (Anon ty)
-- This is the *only* constraint currently handled in types.
| Just (mk, k1, k2) <- get_eq_tys_maybe substed_ty
= do { co <- unifyKind Nothing k1 k2
......
......@@ -873,9 +873,9 @@ can_eq_nc'
-> TcS (StopOrContinue Ct)
-- 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
| Just ty1' <- tcView ty1 = can_eq_nc flat 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
can_eq_nc' flat rdr_env envs 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 rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2
-- need to check for reflexivity in the ReprEq case.
-- See Note [Eager reflexivity check]
......@@ -1048,7 +1048,7 @@ can_eq_nc_forall ev eq_rel s1 s2
-- | Compare types for equality, while zonking as necessary. Gives up
-- as soon as it finds that two types are not equal.
-- 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).
-- In particular, this function makes a ~20% improvement in test case
-- perf/compiler/T5030.
......@@ -1836,10 +1836,11 @@ canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
| k1 `tcEqType` k2
= canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
-- Note [Flattening] in TcFlatten gives us (F2), which says that
-- flattening is always homogeneous (doesn't change kinds). But
-- perhaps by flattening the kinds of the two sides of the equality
-- at hand makes them equal. So let's try that.
-- So the LHS and RHS don't have equal kinds
-- Note [Flattening] in TcFlatten gives us (F2), which says that
-- flattening is always homogeneous (doesn't change kinds). But
-- perhaps by flattening the kinds of the two sides of the equality
-- at hand makes them equal. So let's try that.
| otherwise
= 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)
......@@ -1852,7 +1853,7 @@ canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
, ppr flat_k2
, 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
-- then call canEqTyVarHomo. If they don't equal, just rewriteEqEvidence
-- (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
-- See Note [Equalities with incompatible kinds]
| otherwise -- Wanted and Derived
-- NB: all kind equalities are Nominal
-- NB: all kind equalities are Nominal
= do { emitNewDerivedEq kind_loc Nominal ki1 ki2
-- kind_ev :: (ki1 :: *) ~ (ki2 :: *)
; traceTcS "Hetero equality gives rise to derived kind equality" $
......
......@@ -1975,17 +1975,16 @@ misMatchMsg ct oriented ty1 ty2
-- themselves.
pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin
-> SDoc -> SDoc
pprWithExplicitKindsWhenMismatch ty1 ty2 ct =
pprWithExplicitKindsWhen mismatch
pprWithExplicitKindsWhenMismatch ty1 ty2 ct
= pprWithExplicitKindsWhen show_kinds
where
(act_ty, exp_ty) = case ct of
TypeEqOrigin { uo_actual = act
, uo_expected = exp } -> (act, exp)
_ -> (ty1, ty2)
mismatch | Just vis <- tcEqTypeVis act_ty exp_ty
= not vis
| otherwise
= False
show_kinds = tcEqTypeVis act_ty exp_ty
-- True when the visible bit of the types look the same,
-- so we want to show the kinds in the displayed type
mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool
-> (Bool, Maybe SwapFlag, SDoc)
......
......@@ -1329,8 +1329,7 @@ flatten_exact_fam_app_fully tc tys
-- See Note [Reduce type family applications eagerly]
-- the following tcTypeKind should never be evaluated, as it's just used in
-- casting, and casts by refl are dropped
= do { let reduce_co = mkNomReflCo (tcTypeKind (mkTyConApp tc tys))
; mOut <- try_to_reduce_nocache tc tys reduce_co id
= do { mOut <- try_to_reduce_nocache tc tys
; case mOut of
Just out -> pure out
Nothing -> do
......@@ -1452,16 +1451,8 @@ flatten_exact_fam_app_fully tc tys
try_to_reduce_nocache :: TyCon -- F, family tycon
-> [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))
try_to_reduce_nocache tc tys kind_co update_co
try_to_reduce_nocache tc tys
= do { checkStackDepth (mkTyConApp tc tys)
; mb_match <- liftTcS $ matchFam tc tys
; case mb_match of
......@@ -1470,13 +1461,9 @@ flatten_exact_fam_app_fully tc tys
Just (norm_co, norm_ty)
-> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty
; eq_rel <- getEqRel
; let co = maybeSubCo eq_rel norm_co
`mkTransCo` mkSymCo final_co
role = eqRelRole eq_rel
xi' = xi `mkCastTy` kind_co
co' = update_co $
mkTcCoherenceLeftCo role xi kind_co (mkSymCo co)
; return $ Just (xi', co') }
; let co = mkSymCo (maybeSubCo eq_rel norm_co
`mkTransCo` mkSymCo final_co)
; return $ Just (xi, co) }
Nothing -> pure Nothing }
{- Note [Reduce type family applications eagerly]
......
......@@ -204,6 +204,7 @@ data ZonkEnv -- See Note [The ZonkEnv]
, ze_tv_env :: TyCoVarEnv TyCoVar
, ze_id_env :: IdEnv Id
, ze_meta_tv_env :: TcRef (TyVarEnv Type) }
{- Note [The ZonkEnv]
~~~~~~~~~~~~~~~~~~~~~
* 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
bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
do { stupid_theta <- tcHsContext hs_ctxt
; (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
-- Add constraints from the data constructors
; mapM_ (wrapLocM_ kcConDecl) hs_cons
-- Add constraints from the result signature
; 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) }
-- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts]
......@@ -894,7 +899,7 @@ There are several fiddly subtleties lurking here
'k1' and 'k2', as well as 'b'.
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
axiom AxDrep forall a b. D [(a,b]] = Drep a b
......
......@@ -6,7 +6,7 @@
Monadic type operations
This module contains monadic operations over types that contain
mutable type variables
mutable type variables.
-}
{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}
......@@ -784,10 +784,8 @@ writeMetaTyVarRef tyvar ref ty
= do { meta_details <- readMutVar ref;
-- Zonk kinds to allow the error check to work
; zonked_tv_kind <- zonkTcType tv_kind
; zonked_ty <- zonkTcType ty
; let zonked_ty_kind = tcTypeKind zonked_ty -- Need to zonk even before typeKind;
-- otherwise, we can panic in piResultTy
kind_check_ok = tcIsConstraintKind zonked_tv_kind
; zonked_ty_kind <- zonkTcType ty_kind
; let kind_check_ok = tcIsConstraintKind zonked_tv_kind
|| tcEqKind zonked_ty_kind zonked_tv_kind
-- Hack alert! tcIsConstraintKind: see TcHsType
-- Note [Extra-constraint holes in partial type signatures]
......@@ -813,6 +811,7 @@ writeMetaTyVarRef tyvar ref ty
; writeMutVar ref (Indirect ty) }
where
tv_kind = tyVarKind tyvar
ty_kind = tcTypeKind ty
tv_lvl = tcTyVarLevel tyvar
ty_lvl = tcTypeLevel ty
......@@ -1518,15 +1517,14 @@ defaultTyVar default_kind tv
; writeMetaTyVar tv liftedRepTy
; return True }
| default_kind -- -XNoPolyKinds and this is a kind var
= do { default_kind_var tv -- so default it to * if possible
; return True }
| default_kind -- -XNoPolyKinds and this is a kind var
= default_kind_var tv -- so default it to * if possible
| otherwise
= return False
where
default_kind_var :: TyVar -> TcM ()
default_kind_var :: TyVar -> TcM Bool
-- defaultKindVar is used exclusively with -XNoPolyKinds
-- See Note [Defaulting with -XNoPolyKinds]
-- It takes an (unconstrained) meta tyvar and defaults it.
......@@ -1534,11 +1532,20 @@ defaultTyVar default_kind tv
default_kind_var kv
| isLiftedTypeKind (tyVarKind kv)
= do { traceTc "Defaulting a kind var to *" (ppr kv)
; writeMetaTyVar kv liftedTypeKind }
; writeMetaTyVar kv liftedTypeKind
; return True }
| otherwise
= addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')
, text "of kind:" <+> ppr (tyVarKind kv')
, text "Perhaps enable PolyKinds or add a kind signature" ])
= do { addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')
, text "of kind:" <+> ppr (tyVarKind kv')
, 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
(_, kv') = tidyOpenTyCoVar emptyTidyEnv kv
......@@ -1937,7 +1944,7 @@ zonkTcTypeMapper = TyCoMapper
, tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv)
, tcm_hole = hole
, tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv
, tcm_tycon = return }
, tcm_tycon = zonk_tc_tycon }
where
hole :: () -> CoercionHole -> TcM Coercion
hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
......@@ -1948,6 +1955,12 @@ zonkTcTypeMapper = TyCoMapper
Nothing -> do { cv' <- zonkCoVar 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 tyvars bound at a for-all, zonkType zonks them to an immutable
-- type variable and zonks the kind too
......
......@@ -3401,10 +3401,8 @@ newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts
emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion
-- | Emit a new Wanted equality into the work-list
emitNewWantedEq loc role ty1 ty2
| otherwise
= do { (ev, co) <- newWantedEq loc role ty1 ty2
; updWorkListTcS $
extendWorkListEq (mkNonCanonical ev)
; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))
; return co }
-- | Make a new equality CtEvidence
......
......@@ -39,7 +39,6 @@ import {-# SOURCE #-} TcInstDcls( tcInstDecls1 )
import TcDeriv (DerivInfo)
import TcHsType
import ClsInst( AssocInstInfo(..) )
import Inst( tcInstTyBinders )
import TcMType
import TysWiredIn ( unitTy )
import TcType
......@@ -1742,7 +1741,7 @@ kcTyFamInstEqn tc_fam_tc
; discardResult $
bindImplicitTKBndrs_Q_Tv imp_vars $
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 }
-- Why "_Tv" here? Consider (Trac #14066
-- type family Bar x y where
......@@ -1870,7 +1869,7 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
solveEqualities $
bindImplicitTKBndrs_Q_Skol imp_vars $
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
-- parent class (#16008)
; addConsistencyConstraints mb_clsinfo lhs_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
; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs)
; 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
......@@ -1942,9 +1904,7 @@ tcFamTyPats :: TyCon
-- Used for both type and data families
tcFamTyPats fam_tc hs_pats
= do { traceTc "tcFamTyPats {" $
vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind
, text "arity:" <+> ppr fam_arity
, text "kind:" <+> ppr fam_kind ]
vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]
; let fun_ty = mkTyConApp fam_tc []
......@@ -1952,18 +1912,15 @@ tcFamTyPats fam_tc hs_pats
setXOptM LangExt.PartialTypeSignatures $
-- See Note [Wildcards in family instances] in
-- RnSource.hs
tcInferApps typeLevelMode lhs_fun fun_ty
fam_kind hs_pats
tcInferApps typeLevelMode lhs_fun fun_ty hs_pats
; traceTc "End tcFamTyPats }" $
vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind
, text "res_kind:" <+> ppr res_kind ]
vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ]
; return (fam_app, res_kind) }
where
fam_name = tyConName fam_tc
fam_arity = tyConArity fam_tc
fam_kind = tyConKind fam_tc
lhs_fun = noLoc (HsTyVar noExt NotPromoted (noLoc fam_name))
unravelFamInstPats :: TcType -> [TcType]
......
This diff is collapsed.
......@@ -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
-- 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,
-- we want to update the origin to reflect the
-- instantiation. If we *have* recurred through
......@@ -1450,12 +1450,12 @@ uType t_or_k origin orig_ty1 orig_ty2
go (AppTy s1 t1) (TyConApp tc2 ts2)
| Just (ts2', t2') <- snocView ts2
= ASSERT( mightBeUnsaturatedTyCon tc2 )
= ASSERT( not (mustBeSaturated tc2) )
go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'
go (TyConApp tc1 ts1) (AppTy s2 t2)
| Just (ts1', t1') <- snocView ts1
= ASSERT( mightBeUnsaturatedTyCon tc1 )
= ASSERT( not (mustBeSaturated tc1) )
go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2
go (CoercionTy co1) (CoercionTy co2)
......@@ -2019,37 +2019,43 @@ we return a made-up TcTyVarDetails, but I think it works smoothly.
-}
-- | Breaks apart a function kind into its pieces.
matchExpectedFunKind :: Outputable fun
=> fun -- ^ type, only for errors
-> TcKind -- ^ function kind
-> TcM (Coercion, TcKind, TcKind)
-- ^ co :: old_kind ~ arg -> res
matchExpectedFunKind hs_ty = go
matchExpectedFunKind
:: Outputable fun
=> fun -- ^ type, only for errors
-> Arity -- ^ n: number of desired arrows
-> TcKind -- ^ fun_ kind
-> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res)
matchExpectedFunKind hs_ty n k = go n k
where
go k | Just k' <- tcView k = go k'
go 0 k = return (mkNomReflCo k)
go k@(TyVarTy kvar)
go n k | Just k' <- tcView k = go n k'
go n k@(TyVarTy kvar)
| isMetaTyVar kvar
= do { maybe_kind <- readMetaTyVar kvar
; case maybe_kind of
Indirect fun_kind -> go fun_kind
Flexi -> defer k }
Indirect fun_kind -> go n fun_kind
Flexi -> defer n k }
go n (FunTy arg res)
= do { co <- go (n-1) res
; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co) }
go k@(FunTy arg res) = return (mkNomReflCo k, arg, res)
go other = defer other
go n other
= defer n other
defer k
= do { arg_kind <- newMetaKindVar
; res_kind <- newMetaKindVar
; let new_fun = mkFunTy arg_kind res_kind
defer n k
= do { arg_kinds <- newMetaKindVars n
; res_kind <- newMetaKindVar
; let new_fun = mkFunTys arg_kinds res_kind
origin = TypeEqOrigin { uo_actual = k
, uo_expected = new_fun
, uo_thing = Just (ppr hs_ty)
, uo_visible = True
}
; co <- uType KindLevel origin k new_fun
; return (co, arg_kind, res_kind) }
; uType KindLevel origin k new_fun }
{- *********************************************************************
* *
......
......@@ -430,7 +430,7 @@ splitAppCo_maybe (TyConAppCo r tc args)
, Just (args', arg') <- snocView args
= Just ( mkTyConAppCo r tc args', arg' )
| mightBeUnsaturatedTyCon tc
| not (mustBeSaturated tc)
-- Never create unsaturated type family apps!
, Just (args', arg') <- snocView args
, Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg'
......
......@@ -1159,7 +1159,7 @@ etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)
= ASSERT( tc == tc2 ) Just cos2
etaTyConAppCo_maybe tc co
| mightBeUnsaturatedTyCon tc
| not (mustBeSaturated tc)
, (Pair ty1 ty2, r) <- coercionKindRole co
, Just (tc1, tys1) <- splitTyConApp_maybe ty1
, Just (tc2, tys2) <- splitTyConApp_maybe ty2
......
......@@ -917,8 +917,9 @@ isLiftedRuntimeRep rep
isUnliftedRuntimeRep rep
| Just rep' <- coreView rep = isUnliftedRuntimeRep rep'
| TyConApp rr_tc args <- rep
, isUnliftedRuntimeRepTyCon rr_tc = ASSERT( null args ) True
| TyConApp rr_tc _ <- rep -- NB: args might be non-empty
-- e.g. TupleRep
, isUnliftedRuntimeRepTyCon rr_tc = True
| otherwise = False
isUnliftedRuntimeRepTyCon :: TyCon -> Bool
......@@ -3448,6 +3449,8 @@ pprPrecTypeX env prec ty
if debugStyle sty -- Use debugPprType when in
then debug_ppr_ty prec ty -- when in debug-style
else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty)
-- NB: debug-style is used for -dppr-debug
-- dump-style is used for -ddump-tc-trace etc
pprTyLit :: TyLit -> SDoc
pprTyLit = pprIfaceTyLit . toIfaceTyLit
......
......@@ -50,7 +50,7 @@ module TyCon(
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,
isUnboxedSumTyCon, isPromotedTupleTyCon,
isTypeSynonymTyCon,
mightBeUnsaturatedTyCon,
mustBeSaturated,
isPromotedDataCon, isPromotedDataCon_maybe,
isKindTyCon, isLiftedTypeKindTyConName,
isTauTyCon, isFamFreeTyCon,
......@@ -69,7 +69,8 @@ module TyCon(
isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe,
isImplicitTyCon,
isTyConWithSrcDataCons,
isTcTyCon, isTcLevPoly,
isTcTyCon, setTcTyConKind,
isTcLevPoly,
-- ** Extracting information out of TyCons
tyConName,
......@@ -108,7 +109,7 @@ module TyCon(
pprPromotionQuote, mkTyConKind,
-- ** Predicated on TyConFlavours
tcFlavourCanBeUnsaturated, tcFlavourIsOpen,
tcFlavourIsOpen,
-- * Runtime type representation
TyConRepName, tyConRepName_maybe,
......@@ -1930,11 +1931,11 @@ isFamFreeTyCon _ = True
-- (T ~N d), (a ~N e) and (b ~N f)?
-- Specifically NOT true of synonyms (open and otherwise)
--
-- It'd be unusual to call mightBeUnsaturatedTyCon on a regular H98
-- It'd be unusual to call mustBeSaturated on a regular H98
-- type synonym, because you should probably have expanded it first
-- But regardless, it's not decomposable
mightBeUnsaturatedTyCon :: TyCon -> Bool
mightBeUnsaturatedTyCon = tcFlavourCanBeUnsaturated . tyConFlavour
mustBeSaturated :: TyCon -> Bool
mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour
-- | Is this an algebraic 'TyCon' declared with the GADT syntax?
isGadtSyntaxTyCon :: TyCon -> Bool
......@@ -2131,6 +2132,14 @@ isTcTyCon :: TyCon -> Bool
isTcTyCon (TcTyCon {}) = True
isTcTyCon _ = False
setTcTyConKind :: TyCon -> Kind -> TyCon
-- Update the Kind of a TcTyCon
-- The new kind is always a zonked version of its previous
-- kind, so we don't need to update any other fields.
-- See Note [The Purely Kinded Invariant] in TcHsType
setTcTyConKind tc@(TcTyCon {}) kind = tc { tyConKind = kind }
setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc)
-- | Could this TyCon ever be levity-polymorphic when fully applied?
-- True is safe. False means we're sure. Does only a quick check
-- based on the TyCon's category.
......@@ -2504,19 +2513,19 @@ tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour
tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav
-- | Can this flavour of 'TyCon' appear unsaturated?
tcFlavourCanBeUnsaturated :: TyConFlavour -> Bool
tcFlavourCanBeUnsaturated ClassFlavour = True
tcFlavourCanBeUnsaturated DataTypeFlavour = True
tcFlavourCanBeUnsaturated NewtypeFlavour = True
tcFlavourCanBeUnsaturated DataFamilyFlavour{} = True
tcFlavourCanBeUnsaturated TupleFlavour{} = True
tcFlavourCanBeUnsaturated SumFlavour = True
tcFlavourCanBeUnsaturated AbstractTypeFlavour = True
tcFlavourCanBeUnsaturated BuiltInTypeFlavour = True
tcFlavourCanBeUnsaturated PromotedDataConFlavour = True
tcFlavourCanBeUnsaturated TypeSynonymFlavour = False
tcFlavourCanBeUnsaturated OpenTypeFamilyFlavour{} = False
tcFlavourCanBeUnsaturated ClosedTypeFamilyFlavour = False
tcFlavourMustBeSaturated :: TyConFlavour -> Bool
tcFlavourMustBeSaturated ClassFlavour = False
tcFlavourMustBeSaturated DataTypeFlavour = False
tcFlavourMustBeSaturated NewtypeFlavour = False
tcFlavourMustBeSaturated DataFamilyFlavour{} = False