Commit a5cea73c authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Turn AThing into ATcTyCon, in TcTyThing

This change tidies up and simplifies (a bit) the knot-tying
when kind-checking groups of type and class declarations.

The trouble (shown by Trac #11356) was that we wanted an error message
(a kind-mismatch) that involved a type mentioned a (AThing k), which
blew up.

Since we now seem to have TcTyCons, I decided to use them here.
It's still not great, but it's easier to understand and more robust.
parent 02c1c573
......@@ -23,7 +23,7 @@ module TcEnv(
lookupGlobal,
-- Local environment
tcExtendKindEnv, tcExtendKindEnv2,
tcExtendKindEnv2,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendLetEnv, tcExtendLetEnvIds,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
......@@ -367,17 +367,14 @@ getInLocalScope = do { lcl_env <- getLclTypeEnv
tcExtendKindEnv2 :: [(Name, TcTyThing)] -> TcM r -> TcM r
-- Used only during kind checking, for TcThings that are
-- AThing or APromotionErr
-- ATcTyCon or APromotionErr
-- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
tcExtendKindEnv2 things thing_inside
= updLclEnv upd_env thing_inside
= do { traceTc "txExtendKindEnv" (ppr things)
; updLclEnv upd_env thing_inside }
where
upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
tcExtendKindEnv nks
= tcExtendKindEnv2 $ mapSnd AThing nks
-----------------------
-- Scoped type and kind variables
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
......@@ -517,7 +514,7 @@ tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
get_tvs (_, ATyVar _ tv) tvs -- See Note [Global TyVars]
= tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv
get_tvs (_, AThing k) tvs = tvs `unionVarSet` tyCoVarsOfType k
get_tvs (_, ATcTyCon tc) tvs = tvs `unionVarSet` tyCoVarsOfType (tyConKind tc)
get_tvs (_, AGlobal {}) tvs = tvs
get_tvs (_, APromotionErr {}) tvs = tvs
......
......@@ -999,12 +999,12 @@ tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon
; case thing of
ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)
AThing kind -> do { data_kinds <- xoptM LangExt.DataKinds
; unless (isTypeLevel (mode_level mode) ||
data_kinds) $
promotionErr name NoDataKinds
; tc <- get_loopy_tc name
; return (mkNakedTyConApp tc [], kind) }
ATcTyCon tc_tc -> do { data_kinds <- xoptM LangExt.DataKinds
; unless (isTypeLevel (mode_level mode) ||
data_kinds) $
promotionErr name NoDataKinds
; tc <- get_loopy_tc name tc_tc
; return (mkNakedTyConApp tc [], tyConKind tc_tc) }
-- mkNakedTyConApp: see Note [Type-checking inside the knot]
-- NB: we really should check if we're at the kind level
-- and if the tycon is promotable if -XNoTypeInType is set.
......@@ -1041,17 +1041,23 @@ tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon
_ -> wrongThingErr "type" thing name }
where
get_loopy_tc name
get_loopy_tc :: Name -> TyCon -> TcM TyCon
-- Return the knot-tied global TyCon if there is one
-- Otherwise the local TcTyCon; we must be doing kind checking
-- but we still want to return a TyCon of some sort to use in
-- error messages
get_loopy_tc name tc_tc
= do { env <- getGblEnv
; case lookupNameEnv (tcg_type_env env) name of
Just (ATyCon tc) -> return tc
_ -> return (aThingErr "tcTyVar" name) }
_ -> do { traceTc "lk1 (loopy)" (ppr name)
; return tc_tc } }
tcClass :: Name -> TcM (Class, TcKind)
tcClass cls -- Must be a class
= do { thing <- tcLookup cls
; case thing of
AThing kind -> return (aThingErr "tcClass" cls, kind)
ATcTyCon tc -> return (aThingErr "tcClass" cls, tyConKind tc)
AGlobal (ATyCon tc)
| Just cls <- tyConClass_maybe tc
-> return (cls, tyConKind tc)
......@@ -1651,7 +1657,7 @@ kcLookupKind :: Name -> TcM Kind
kcLookupKind nm
= do { tc_ty_thing <- tcLookup nm
; case tc_ty_thing of
AThing k -> return k
ATcTyCon tc -> return (tyConKind tc)
AGlobal (ATyCon tc) -> return (tyConKind tc)
_ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) }
......
......@@ -874,9 +874,10 @@ data TcTyThing
-- for error-message purposes; it is the corresponding
-- Name in the domain of the envt
| AThing TcKind -- Used temporarily, during kind checking, for the
| ATcTyCon TyCon -- Used temporarily, during kind checking, for the
-- tycons and clases in this recursive group
-- Can be a mono-kind or a poly-kind; in TcTyClsDcls see
-- The TyCon is always a TcTyCon. Its kind
-- can be a mono-kind or a poly-kind; in TcTyClsDcls see
-- Note [Type checking recursive type and class declarations]
| APromotionErr PromotionErr
......@@ -904,7 +905,7 @@ instance Outputable TcTyThing where -- Debugging only
<> ppr (varType (tct_id elt)) <> comma
<+> ppr (tct_closed elt))
ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv
ppr (AThing k) = text "AThing" <+> ppr k
ppr (ATcTyCon tc) = text "ATcTyCon" <+> ppr tc
ppr (APromotionErr err) = text "APromotionErr" <+> ppr err
instance Outputable PromotionErr where
......@@ -921,7 +922,7 @@ pprTcTyThingCategory :: TcTyThing -> SDoc
pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing
pprTcTyThingCategory (ATyVar {}) = ptext (sLit "Type variable")
pprTcTyThingCategory (ATcId {}) = ptext (sLit "Local identifier")
pprTcTyThingCategory (AThing {}) = ptext (sLit "Kinded thing")
pprTcTyThingCategory (ATcTyCon {}) = ptext (sLit "Local tycon")
pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe
pprPECategory :: PromotionErr -> SDoc
......
......@@ -149,7 +149,8 @@ tcTyClGroup tyclds
-- Also extend the local type envt with bindings giving
-- the (polymorphic) kind of each knot-tied TyCon or Class
-- See Note [Type checking recursive type and class declarations]
tcExtendKindEnv names_w_poly_kinds $
tcExtendKindEnv2 [ mkTcTyConPair name kind
| (name, kind) <- names_w_poly_kinds ] $
-- Kind and type check declarations for this group
mapM (tcTyClDecl rec_flags) decls }
......@@ -289,8 +290,6 @@ kcTyClGroup (TyClGroup { group_tyclds = decls })
-- Step 3: Set extended envt, kind-check the non-synonyms
; setLclEnv lcl_env $
tcExtendRecEnv (tcTyConPairs initial_kinds) $
-- See Note [Kind checking recursive type and class declarations]
mapM_ kcLTyClDecl non_syn_decls
; return lcl_env }
......@@ -304,16 +303,11 @@ kcTyClGroup (TyClGroup { group_tyclds = decls })
; return res }
where
tcTyConPairs :: [(Name,TcTyThing)] -> [(Name,TyThing)]
tcTyConPairs initial_kinds = [ (name, ATyCon tc)
| (name, AThing kind) <- initial_kinds
, let tc = mkTcTyCon name kind ]
generalise :: TcTypeEnv -> Name -> TcM (Name, Kind)
-- For polymorphic things this is a no-op
generalise kind_env name
= do { let kc_kind = case lookupNameEnv kind_env name of
Just (AThing k) -> k
Just (ATcTyCon tc) -> tyConKind tc
_ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env)
; kvs <- kindGeneralize kc_kind
; kc_kind' <- zonkTcTypeToType emptyZonkEnv kc_kind
......@@ -343,6 +337,11 @@ kcTyClGroup (TyClGroup { group_tyclds = decls })
generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name })
= generalise kind_env name
mkTcTyConPair :: Name -> TcKind -> (Name, TcTyThing)
-- Makes a binding to put in the local envt, binding
-- a name to a TcTyCon with the specified kind
mkTcTyConPair name kind = (name, ATcTyCon (mkTcTyCon name kind))
mk_thing_env :: [LTyClDecl Name] -> [(Name, TcTyThing)]
mk_thing_env [] = []
mk_thing_env (decl : decls)
......@@ -361,9 +360,10 @@ getInitialKinds decls
do { pairss <- mapM (addLocM getInitialKind) decls
; return (concat pairss) }
getInitialKind :: TyClDecl Name -> TcM [(Name, TcTyThing)]
getInitialKind :: TyClDecl Name
-> TcM [(Name, TcTyThing)] -- Mixture of ATcTyCon and APromotionErr
-- Allocate a fresh kind variable for each TyCon and Class
-- For each tycon, return (tc, AThing k)
-- For each tycon, return (name, ATcTyCon (TcCyCon with kind k))
-- where k is the kind of tc, derived from the LHS
-- of the definition (and probably including
-- kind unification variables)
......@@ -375,7 +375,7 @@ getInitialKind :: TyClDecl Name -> TcM [(Name, TcTyThing)]
-- * The result kinds signature on a TyClDecl
--
-- ALSO for each datacon, return (dc, APromotionErr RecDataConPE)
-- Note [ARecDataCon: Recursion and promoting data constructors]
-- See Note [ARecDataCon: Recursion and promoting data constructors]
--
-- No family instances are passed to getInitialKinds
......@@ -385,7 +385,7 @@ getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs =
do { inner_prs <- getFamDeclInitialKinds ats
; return (constraintKind, inner_prs) }
; cl_kind <- zonkTcType cl_kind
; let main_pr = (name, AThing cl_kind)
; let main_pr = mkTcTyConPair name cl_kind
; return (main_pr : inner_prs) }
getInitialKind decl@(DataDecl { tcdLName = L _ name
......@@ -399,7 +399,7 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
Nothing -> return liftedTypeKind
; return (res_k, ()) }
; decl_kind <- zonkTcType decl_kind
; let main_pr = (name, AThing decl_kind)
; let main_pr = mkTcTyConPair name decl_kind
inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
| L _ con' <- cons, con <- getConNames con' ]
; return (main_pr : inner_prs) }
......@@ -434,7 +434,7 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name
| otherwise -> newMetaKindVar
; return (res_k, ()) }
; fam_kind <- zonkTcType fam_kind
; return [ (name, AThing fam_kind) ] }
; return [ mkTcTyConPair name fam_kind ] }
----------------
kcSynDecls :: [SCC (LTyClDecl Name)]
......@@ -442,8 +442,8 @@ kcSynDecls :: [SCC (LTyClDecl Name)]
kcSynDecls [] = getLclEnv
kcSynDecls (group : groups)
= do { (n,k) <- kcSynDecl1 group
; lcl_env <- tcExtendKindEnv [(n,k)] (kcSynDecls groups)
; return lcl_env }
; tcExtendKindEnv2 [ mkTcTyConPair n k ] $
kcSynDecls groups }
kcSynDecl1 :: SCC (LTyClDecl Name)
-> TcM (Name,TcKind) -- Kind bindings
......@@ -553,10 +553,10 @@ Consider:
When kind checking the `data T' declaration the local env contains the
mappings:
T -> AThing <some initial kind>
K -> ARecDataCon
T -> ATcTyCon <some initial kind>
K -> APromotionErr
ANothing is only used for DataCons, and only used during type checking
APromotionErr is only used for DataCons, and only used during type checking
in tcTyClGroup.
......@@ -594,8 +594,8 @@ kind-checking the RHS of T's decl, we *do* need to know T's kind (so
that we can correctly elaboarate (T k f a). How can we get T's kind
without looking at T? Delicate answer: during tcTyClDecl, we extend
*Global* env with T -> ATyCon (the (not yet built) TyCon for T)
*Local* env with T -> AThing (polymorphic kind of T)
*Global* env with T -> ATyCon (the (not yet built) final TyCon for T)
*Local* env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T)
Then:
......@@ -621,7 +621,7 @@ using this initial kind for recursive occurrences.
The initial kind is stored in exactly the same way during kind-checking
as it is during type-checking (Note [Type checking recursive type and class
declarations]): in the *local* environment, with AThing. But we still
declarations]): in the *local* environment, with ATcTyCon. But we still
must store *something* in the *global* environment. Even though we
discard the result of kind-checking, we sometimes need to produce error
messages. These error messages will want to refer to the tycons being
......
module T11356 where
class T p p => C p
type T x = C x
T11356.hs:3:7: error:
• Expecting one fewer argument to ‘T p’
Expected kind ‘k0 -> Constraint’, but ‘T p’ has kind ‘Constraint’
• In the class declaration for ‘C’
......@@ -398,4 +398,5 @@ test('T11112', normal, compile_fail, [''])
test('ClassOperator', normal, compile_fail, [''])
test('T11274', normal, compile_fail, [''])
test('T10619', normal, compile_fail, [''])
test('T11347', expect_broken(11347), compile_fail, [''])
test('T11347', normal, compile_fail, [''])
test('T11356', normal, compile_fail, [''])
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