From a7032af4e333a273678801466a08b619af442c42 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 29 Apr 2005 23:37:10 +0000 Subject: [PATCH] [project @ 2005-04-29 23:37:10 by simonpj] Better kind error reporting; MERGE TO STABLE --- ghc/compiler/typecheck/TcEnv.lhs | 13 +++++-- ghc/compiler/typecheck/TcHsType.lhs | 5 ++- ghc/compiler/typecheck/TcTyClsDecls.lhs | 56 ++++++++++++++++++------------- 3 files changed, 45 insertions(+), 29 deletions(-) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index e825223..8657a85 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index ebb97b3..4ef02b1 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 9b664af..120b213 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -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} -- 1.7.10.4