Commit 4a738e17 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Simplify and clean up kind-checking of type/class declarations

This fixes Trac #7341
parent 1152f949
......@@ -825,11 +825,13 @@ kcScopedKindVars kv_ns thing_inside
-- NB: use mutable signature variables
; tcExtendTyVarEnv2 (kv_ns `zip` kvs) thing_inside }
kcHsTyVarBndrs :: Bool -- Default UserTyVar to *
kcHsTyVarBndrs :: Bool -- True <=> full kind signature provided
-- Default UserTyVar to *
-- and use KindVars not meta kind vars
-> LHsTyVarBndrs Name
-> ([TcKind] -> TcM r)
-> TcM r
-- Used in getInitialKind
kcHsTyVarBndrs full_kind_sig (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside
= do { kvs <- if full_kind_sig
then return (map mkKindSigVar kv_ns)
......@@ -848,6 +850,14 @@ kcHsTyVarBndrs full_kind_sig (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thin
; return (n, kind) }
kc_hs_tv (KindedTyVar n k)
= do { kind <- tcLHsKind k
-- In an associated type decl, the type variable may already
-- be in scope; in that case we want to make sure its kind
-- matches the one declared here
; mb_thing <- tcLookupLcl_maybe n
; case mb_thing of
Nothing -> return ()
Just (AThing ks) -> checkKind kind ks
Just thing -> pprPanic "check_in_scope" (ppr thing)
; return (n, kind) }
tcScopedKindVars :: [Name] -> TcM a -> TcM a
......@@ -970,38 +980,29 @@ kcLookupKind nm
AGlobal (ATyCon tc) -> return (tyConKind tc)
_ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) }
kcTyClTyVars :: Name -> LHsTyVarBndrs Name -> (TcKind -> TcM a) -> TcM a
kcTyClTyVars :: Name -> LHsTyVarBndrs Name -> TcM a -> TcM a
-- Used for the type variables of a type or class decl,
-- when doing the initial kind-check.
kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside
= kcScopedKindVars kvs $
do { tc_kind <- kcLookupKind name
; let (arg_ks, res_k) = splitKindFunTysN (length hs_tvs) tc_kind
; let (arg_ks, _res_k) = splitKindFunTysN (length hs_tvs) tc_kind
-- There should be enough arrows, because
-- getInitialKinds used the tcdTyVars
; name_ks <- zipWithM kc_tv hs_tvs arg_ks
; tcExtendKindEnv name_ks (thing_inside res_k) }
; tcExtendKindEnv name_ks thing_inside }
where
-- getInitialKind has already gotten the kinds of these type
-- variables, but tiresomely we need to check them *again*
-- to match the kind variables they mention against the ones
-- we've freshly brought into scope
kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind)
kc_tv (L _ (UserTyVar n)) exp_k
= do { check_in_scope n exp_k
; return (n, exp_k) }
= return (n, exp_k)
kc_tv (L _ (KindedTyVar n hs_k)) exp_k
= do { k <- tcLHsKind hs_k
; checkKind k exp_k
; check_in_scope n exp_k
; return (n, k) }
check_in_scope :: Name -> Kind -> TcM ()
-- In an associated type decl, the type variable may already
-- be in scope; in that case we want to make sure it matches
-- any signature etc here
check_in_scope n exp_k
= do { mb_thing <- tcLookupLcl_maybe n
; case mb_thing of
Nothing -> return ()
Just (AThing k) -> checkKind k exp_k
Just thing -> pprPanic "check_in_scope" (ppr thing) }
; return (n, exp_k) }
-----------------------
tcTyClTyVars :: Name -> LHsTyVarBndrs Name -- LHS of the type or class decl
......
......@@ -128,7 +128,7 @@ tcTyClGroup boot_details tyclds
-- Populate environment with knot-tied ATyCon for TyCons
-- NB: if the decls mention any ill-staged data cons
-- (see Note [ARecDataCon: Recusion and promoting data constructors]
-- (see Note [Recusion and promoting data constructors]
-- we will have failed already in kcTyClGroup, so no worries here
; tcExtendRecEnv (zipRecTyClss names_w_poly_kinds rec_tyclss) $
......@@ -324,8 +324,12 @@ getInitialKind :: TopLevelFlag -> TyClDecl Name -> TcM [(Name, TcTyThing)]
-- Example: data T a b = ...
-- return (T, kv1 -> kv2 -> kv3)
--
-- ALSO for each datacon, return (dc, ARecDataCon)
-- Note [ARecDataCon: Recusion and promoting data constructors]
-- This pass deals with (ie incorporates into the kind it produces)
-- * The kind signatures on type-variable binders
-- * The result kinds signature on a TyClDecl
--
-- ALSO for each datacon, return (dc, APromotionErr RecDataConPE)
-- Note [ARecDataCon: Recursion and promoting data constructors]
--
-- No family instances are passed to getInitialKinds
......@@ -361,14 +365,15 @@ getInitialKind top_lvl decl@(TyDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcd
kvs = varSetElems (tyVarsOfType body_kind)
main_pr = (name, AThing (mkForAllTys kvs body_kind))
inner_prs = [(unLoc (con_name con), APromotionErr RecDataConPE) | L _ con <- cons ]
-- See Note [ARecDataCon: Recusion and promoting data constructors]
-- See Note [Recusion and promoting data constructors]
; return (main_pr : inner_prs) }
| TyData { td_cons = cons } <- defn
= kcHsTyVarBndrs False ktvs $ \ arg_kinds ->
do { let main_pr = (name, AThing (mkArrowKinds arg_kinds liftedTypeKind))
inner_prs = [(unLoc (con_name con), APromotionErr RecDataConPE) | L _ con <- cons ]
-- See Note [ARecDataCon: Recusion and promoting data constructors]
inner_prs = [ (unLoc (con_name con), APromotionErr RecDataConPE)
| L _ con <- cons ]
-- See Note [Recusion and promoting data constructors]
; return (main_pr : inner_prs) }
| otherwise = pprPanic "getInitialKind" (ppr decl)
......@@ -413,13 +418,18 @@ kcLTyClDecl (L loc decl)
kcTyClDecl :: TyClDecl Name -> TcM ()
-- This function is used solely for its side effect on kind variables
-- NB kind signatures on the type variables and
-- result kind signature have aready been dealt with
-- by getInitialKind, so we can ignore them here.
kcTyClDecl decl@(TyDecl { tcdLName = L _ name, tcdTyVars = hs_tvs, tcdTyDefn = defn })
| TyData { td_cons = cons, td_kindSig = Just _ } <- defn
= mapM_ (wrapLocM kcConDecl) cons -- Ignore the td_ctxt; heavily deprecated and inconvenient
= mapM_ (wrapLocM kcConDecl) cons
-- hs_tvs and td_kindSig already dealt with in getInitialKind
-- Ignore the td_ctxt; heavily deprecated and inconvenient
| TyData { td_ctxt = ctxt, td_cons = cons } <- defn
= kcTyClTyVars name hs_tvs $ \ _res_k ->
= kcTyClTyVars name hs_tvs $
do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM kcConDecl) cons }
......@@ -427,7 +437,7 @@ kcTyClDecl decl@(TyDecl { tcdLName = L _ name, tcdTyVars = hs_tvs, tcdTyDefn = d
kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
, tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
= kcTyClTyVars name hs_tvs $ \ _res_k ->
= kcTyClTyVars name hs_tvs $
do { _ <- tcHsContext ctxt
; mapM_ (wrapLocM kcTyClDecl) ats
; mapM_ (wrapLocM kc_sig) sigs }
......@@ -436,8 +446,8 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs
kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty)
kc_sig _ = return ()
kcTyClDecl (ForeignType {}) = return ()
kcTyClDecl (TyFamily {}) = return ()
kcTyClDecl (ForeignType {}) = return ()
-------------------
kcConDecl :: ConDecl Name -> TcM ()
......@@ -451,8 +461,8 @@ kcConDecl (ConDecl { con_name = name, con_qvars = ex_tvs
; return () }
\end{code}
Note [ARecDataCon: Recusion and promoting data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note [Recursion and promoting data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We don't want to allow promotion in a strongly connected component
when kind checking.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment