Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-kinds
http://hackage.haskell.org/trac/ghc/changeset/e0af4547a7850bd78410b8136100e0c2668544b6 >--------------------------------------------------------------- commit e0af4547a7850bd78410b8136100e0c2668544b6 Author: Jose Pedro Magalhaes <[email protected]> Date: Tue Nov 15 10:09:50 2011 +0000 Better error messages when we know the expected kind >--------------------------------------------------------------- compiler/typecheck/TcHsType.lhs | 33 +++++++++++++++------------------ compiler/typecheck/TcMType.lhs | 23 +++++++++++++++-------- compiler/types/Kind.lhs | 21 +++++++++++++-------- 3 files changed, 43 insertions(+), 34 deletions(-) diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 6512f72..3d916d3 100755 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -74,7 +74,7 @@ import UniqSupply import Outputable import BuildTyCl ( buildPromotedDataTyCon ) import FastString -import Control.Monad ( unless, when ) +import Control.Monad ( unless ) \end{code} @@ -172,22 +172,14 @@ tcHsSigType ctxt hs_ty tcHsSigTypeNC ctxt hs_ty = do { -- (kinded_ty, _kind) <- kc_lhs_type hs_ty - kinded_ty <- if interestingCtxt ctxt - -- In these cases we don't know the expected kind - then fmap fst (kc_lhs_type hs_ty) - -- In the remaining cases (FunSigCtxt, DefaultDeclCtxt, - -- ExprSigCtxt, and ForSigCtxt), we expect kind * - -- Using kcCheckLHsType we give better error messages - else kcCheckLHsType hs_ty ekOpen + kinded_ty <- case expectedKindInCtxt ctxt of + Nothing -> fmap fst (kc_lhs_type hs_ty) + Just k -> kc_check_lhs_type hs_ty (EK k EkUnk) -- JPM fix this -- The kind is checked by checkValidType, and isn't necessarily -- of kind * in a Template Haskell quote eg [t| Maybe |] ; ty <- tcHsKindedType kinded_ty - ; when (interestingCtxt ctxt) $ checkValidType ctxt ty + ; checkValidType ctxt ty ; return ty } - where - interestingCtxt GhciCtxt = True - interestingCtxt ThBrackCtxt = True - interestingCtxt _ = False -- Like tcHsType, but takes an expected kind tcCheckHsType :: LHsType Name -> Kind -> TcM Type @@ -1362,9 +1354,9 @@ sc_ds_var_app name arg_kis -- General case sc_ds_var_app name arg_kis = do - thing <- tcLookup name - case thing of - AGlobal (ATyCon tc) + (_errs, mb_thing) <- tryTc (tcLookup name) + case mb_thing of + Just (AGlobal (ATyCon tc)) | isAlgTyCon tc || isTupleTyCon tc -> do poly_kinds <- xoptM Opt_PolyKinds unless poly_kinds $ addErr (polyKindsErr name) @@ -1374,8 +1366,13 @@ sc_ds_var_app name arg_kis = do return (mkTyConApp (mkPromotedTypeTyCon tc) arg_kis) Just _ -> err tc_kind "is not fully applied" Nothing -> err tc_kind "is not promotable" - - _ -> wrongThingErr "promoted type" thing name + -- It is in scope, but not what we expected + Just thing -> wrongThingErr "promoted type" thing name + -- It is not in scope, but it passed the renamer: staging error + Nothing -> ASSERT2 ( isTyConName name, ppr name ) + failWithTc (ptext (sLit "Promoted kind") <+> + quotes (ppr name) <+> + ptext (sLit "used in a mutually recursive group")) where err k m = failWithTc ( quotes (ppr name) <+> ptext (sLit "of kind") <+> quotes (ppr k) <+> ptext (sLit m)) diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 29ec51c..3dc8d1c 100755 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -50,6 +50,7 @@ module TcMType ( -------------------------------- -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, + expectedKindInCtxt, checkValidTheta, checkValidInstHead, checkValidInstance, validDerivPred, checkInstTermination, checkValidFamInst, checkTyFamFreeness, @@ -883,6 +884,17 @@ This might not necessarily show up in kind checking. \begin{code} +-- Depending on the context, we might accept any kind (for instance, in a TH +-- splice), or only certain kinds (like in type signatures). +expectedKindInCtxt :: UserTypeCtxt -> Maybe Kind +expectedKindInCtxt (TySynCtxt _) = Nothing -- Any kind will do +expectedKindInCtxt ThBrackCtxt = Nothing +expectedKindInCtxt GhciCtxt = Nothing +expectedKindInCtxt ResSigCtxt = Just openTypeKind +expectedKindInCtxt ExprSigCtxt = Just openTypeKind +expectedKindInCtxt (ForSigCtxt _) = Just liftedTypeKind +expectedKindInCtxt _ = Just argTypeKind + checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that the type is valid for the given context checkValidType ctxt ty = do @@ -920,14 +932,9 @@ checkValidType ctxt ty = do actual_kind = typeKind ty - kind_ok = case ctxt of - TySynCtxt _ -> True -- Any kind will do - ThBrackCtxt -> True -- ditto - GhciCtxt -> True -- ditto - ResSigCtxt -> tcIsSubOpenTypeKind actual_kind - ExprSigCtxt -> tcIsSubOpenTypeKind actual_kind - ForSigCtxt _ -> isLiftedTypeKind actual_kind - _ -> tcIsSubArgTypeKind actual_kind + kind_ok = case expectedKindInCtxt ctxt of + Nothing -> True + Just k -> tcIsSubKind actual_kind k ubx_tup | not unboxed = UT_NotOk diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index 1358578..31a567d 100755 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -42,7 +42,7 @@ module Kind ( isSubArgTypeKind, tcIsSubArgTypeKind, isSubOpenTypeKind, tcIsSubOpenTypeKind, - isSubKind, defaultKind, + isSubKind, tcIsSubKind, defaultKind, isSubKindCon, tcIsSubKindCon, isSubOpenTypeKindCon, -- ** Functions on variables @@ -229,13 +229,18 @@ isSuperKind _ = False isKind :: Kind -> Bool isKind k = isSuperKind (typeKind k) -isSubKind :: Kind -> Kind -> Bool +isSubKind, tcIsSubKind :: Kind -> Kind -> Bool +isSubKind = isSubKind' False +tcIsSubKind = isSubKind' True + +-- The first argument denotes whether we are in the type-checking phase or not +isSubKind' :: Bool -> Kind -> Kind -> Bool -- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@ -isSubKind (FunTy a1 r1) (FunTy a2 r2) - = (a2 `isSubKind` a1) && (r1 `isSubKind` r2) +isSubKind' duringTc (FunTy a1 r1) (FunTy a2 r2) + = (isSubKind' duringTc a2 a1) && (isSubKind' duringTc r1 r2) -isSubKind k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) +isSubKind' duringTc k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) | isPromotedTypeTyCon kc1 || isPromotedTypeTyCon kc2 -- handles promoted kinds (List *, Nat, etc.) = eqKind k1 k2 @@ -247,10 +252,10 @@ isSubKind k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) | otherwise = -- handles usual kinds (*, #, (#), etc.) ASSERT2( null k1s && null k2s, ppr k1 <+> ppr k2 ) - kc1 `isSubKindCon` kc2 - + if duringTc then kc1 `tcIsSubKindCon` kc2 + else kc1 `isSubKindCon` kc2 -isSubKind k1 k2 = eqKind k1 k2 +isSubKind' _duringTc k1 k2 = eqKind k1 k2 isSubKindCon :: TyCon -> TyCon -> Bool -- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@ _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
