Commit a7032af4 authored by simonpj's avatar simonpj
Browse files

[project @ 2005-04-29 23:37:10 by simonpj]

Better kind error reporting; MERGE TO STABLE
parent 616069b3
......@@ -16,7 +16,7 @@ module TcEnv(
tcLookupLocatedClass,
-- Local environment
tcExtendKindEnv,
tcExtendKindEnv, tcExtendKindEnvTvs,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcLookup, tcLookupLocated, tcLookupLocalIds,
......@@ -42,7 +42,8 @@ module TcEnv(
#include "HsVersions.h"
import HsSyn ( LRuleDecl, LHsBinds, LSig, pprLHsBinds )
import HsSyn ( LRuleDecl, LHsBinds, LSig,
LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds )
import TcIface ( tcImportDecl )
import IfaceEnv ( newGlobalBinder )
import TcRnTypes ( pprTcTyThingCategory )
......@@ -243,6 +244,14 @@ tcExtendKindEnv things thing_inside
upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
tcExtendKindEnvTvs bndrs thing_inside
= updLclEnv upd thing_inside
where
upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
extend env = extendNameEnvList env pairs
pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tvs thing_inside
= tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
......
......@@ -28,7 +28,7 @@ import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, HsBang,
getBangStrictness, collectSigTysFromHsBinds )
import RnHsSyn ( extractHsTyVars )
import TcRnMonad
import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv,
import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnvTvs,
tcLookup, tcLookupClass, tcLookupTyCon,
TyThing(..), getInLocalScope, wrongThingErr
)
......@@ -603,8 +603,7 @@ kcHsTyVars :: [LHsTyVarBndr Name]
-> TcM r
kcHsTyVars tvs thing_inside
= mappM (wrapLocM kcHsTyVar) tvs `thenM` \ bndrs ->
tcExtendKindEnv [(n,k) | L _ (KindedTyVar n k) <- bndrs]
(thing_inside bndrs)
tcExtendKindEnvTvs bndrs (thing_inside bndrs)
kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name)
-- Return a *kind-annotated* binder, and a tyvar with a mutable kind in it
......
......@@ -13,7 +13,7 @@ module TcTyClsDecls (
import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..),
ConDecl(..), Sig(..), , NewOrData(..),
tyClDeclTyVars, isSynDecl,
LTyClDecl, tcdName, LHsTyVarBndr
LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr
)
import HsTypes ( HsBang(..), getBangStrictness )
import BasicTypes ( RecFlag(..), StrictnessMark(..) )
......@@ -23,7 +23,7 @@ import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon,
import TcRnMonad
import TcEnv ( TyThing(..),
tcLookupLocated, tcLookupLocatedGlobal,
tcExtendGlobalEnv, tcExtendKindEnv,
tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs,
tcExtendRecEnv, tcLookupTyVar )
import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles )
import TcClassDcl ( tcClassSigs, tcAddDeclCtxt )
......@@ -32,11 +32,11 @@ import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType,
kcHsSigType, tcHsBangType, tcLHsConSig, tcDataKindSig )
import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness,
UserTypeCtxt(..), SourceTyCtxt(..) )
import TcUnify ( unifyKind )
import TcType ( TcKind, TcType, tyVarsOfType,
mkArrowKind, liftedTypeKind, mkTyVarTys, tcEqTypes,
tcSplitSigmaTy, tcEqType )
import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType )
import Kind ( mkArrowKinds, splitKindFunTys )
import Generics ( validGenericMethodType, canDoGenerics )
import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars )
import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ),
......@@ -229,10 +229,22 @@ kcTyClDecls syn_decls alg_decls
------------------------------------------------------------------------
getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind)
-- Only for data type and class declarations
-- Get as much info as possible from the data or class decl,
-- so as to maximise usefulness of error messages
getInitialKind (L _ decl)
= do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
; res_kind <- mk_res_kind decl
; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
where
mk_arg_kind (UserTyVar _) = newKindVar
mk_arg_kind (KindedTyVar _ kind) = return kind
mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind
-- On GADT-style declarations we allow a kind signature
-- data T :: *->* where { ... }
mk_res_kind other = return liftedTypeKind
getInitialKind decl
= newKindVar `thenM` \ kind ->
returnM (unLoc (tcdLName (unLoc decl)), kind)
----------------
kcSynDecls :: [SCC (LTyClDecl Name)]
......@@ -264,6 +276,8 @@ kcSynDecl (CyclicSCC decls)
= do { recSynErr decls; failM } -- Fail here to avoid error cascade
-- of out-of-scope tycons
kindedTyVarKind (L _ (KindedTyVar _ k)) = k
------------------------------------------------------------------------
kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
-- Not used for type synonyms (see kcSynDecl)
......@@ -316,27 +330,21 @@ kcTyClDecl decl@(ForeignType {})
kcTyClDeclBody :: TyClDecl Name
-> ([LHsTyVarBndr Name] -> TcM a)
-> TcM a
-- Extend the env with bindings for the tyvars, taken from
-- the kind of the tycon/class. Give it to the thing inside, and
-- check the result kind matches
-- getInitialKind has made a suitably-shaped kind for the type or class
-- Unpack it, and attribute those kinds to the type variables
-- Extend the env with bindings for the tyvars, taken from
-- the kind of the tycon/class. Give it to the thing inside, and
-- check the result kind matches
kcTyClDeclBody decl thing_inside
= tcAddDeclCtxt decl $
kcHsTyVars (tyClDeclTyVars decl) $ \ kinded_tvs ->
do { tc_ty_thing <- tcLookupLocated (tcdLName decl)
; let tc_kind = case tc_ty_thing of { AThing k -> k }
;
; traceTc (text "kcbody" <+> ppr decl <+> ppr tc_kind <+> ppr (map kindedTyVarKind kinded_tvs) <+> ppr (result_kind decl))
; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind)
(result_kind decl)
kinded_tvs)
; thing_inside kinded_tvs }
where
result_kind (TyData { tcdKindSig = Just kind }) = kind
result_kind other = liftedTypeKind
-- On GADT-style declarations we allow a kind signature
-- data T :: *->* where { ... }
kindedTyVarKind (L _ (KindedTyVar _ k)) = k
; let tc_kind = case tc_ty_thing of { AThing k -> k }
(kinds, _) = splitKindFunTys tc_kind
hs_tvs = tcdTyVars decl
kinded_tvs = ASSERT( length kinds >= length hs_tvs )
[ L loc (KindedTyVar (hsTyVarName tv) k)
| (L loc tv, k) <- zip hs_tvs kinds]
; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) }
\end{code}
......
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