X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsType.lhs;h=b29dc9a12005759a207d2903e0328a8722978fd4;hp=66102a64dfd36cd5a9d89db9349cca099d5bd4a3;hb=3710a4ef1ca665fe4ed705a6b0f4400d680c7b54;hpb=f59d6c9d6ead47a61681b1086b313c2fad225912 diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 66102a6..b29dc9a 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -5,12 +5,7 @@ \section[TcMonoType]{Typechecking user-specified @MonoTypes@} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details +{-# LANGUAGE RelaxedPolyRec #-} module TcHsType ( tcHsSigType, tcHsDeriv, @@ -19,7 +14,7 @@ module TcHsType ( -- Kind checking kcHsTyVars, kcHsSigType, kcHsLiftedSigType, - kcCheckHsType, kcHsContext, kcHsType, + kcLHsType, kcCheckLHsType, kcHsContext, -- Typechecking kinded types tcHsKindedContext, tcHsKindedType, tcHsBangType, @@ -42,6 +37,7 @@ import TcIface import TcType import {- Kind parts of -} Type import Var +import Coercion import TyCon import Class import Name @@ -53,6 +49,7 @@ import BasicTypes import SrcLoc import UniqSupply import Outputable +import FastString import Control.Monad \end{code} @@ -172,13 +169,15 @@ tcHsQuantifiedType tv_names hs_ty ; return (tvs, ty) } } -- Used for the deriving(...) items -tcHsDeriv :: LHsType Name -> TcM ([TyVar], Class, [Type]) -tcHsDeriv = addLocM (tc_hs_deriv []) +tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type]) +tcHsDeriv = tc_hs_deriv [] +tc_hs_deriv :: [LHsTyVarBndr Name] -> HsType Name + -> TcM ([TyVar], Class, [Type]) tc_hs_deriv tv_names (HsPredTy (HsClassP cls_name hs_tys)) = kcHsTyVars tv_names $ \ tv_names' -> do { cls_kind <- kcClass cls_name - ; (tys, res_kind) <- kcApps cls_kind (ppr cls_name) hs_tys + ; (tys, _res_kind) <- kcApps cls_name cls_kind hs_tys ; tcTyVarBndrs tv_names' $ \ tyvars -> do { arg_tys <- dsHsTypes tys ; cls <- tcLookupClass cls_name @@ -191,7 +190,7 @@ tc_hs_deriv tv_names1 (HsForAllTy _ tv_names2 (L _ []) (L _ ty)) tc_hs_deriv (tv_names1 ++ tv_names2) ty tc_hs_deriv _ other - = failWithTc (ptext SLIT("Illegal deriving item") <+> ppr other) + = failWithTc (ptext (sLit "Illegal deriving item") <+> ppr other) \end{code} These functions are used during knot-tying in @@ -201,8 +200,8 @@ tc_hs_deriv _ other \begin{code} kcHsSigType, kcHsLiftedSigType :: LHsType Name -> TcM (LHsType Name) -- Used for type signatures -kcHsSigType ty = kcTypeType ty -kcHsLiftedSigType ty = kcLiftedType ty +kcHsSigType ty = addKcTypeCtxt ty $ kcTypeType ty +kcHsLiftedSigType ty = addKcTypeCtxt ty $ kcLiftedType ty tcHsKindedType :: LHsType Name -> TcM Type -- Don't do kind checking, nor validity checking. @@ -213,8 +212,8 @@ tcHsKindedType hs_ty = dsHsType hs_ty tcHsBangType :: LHsType Name -> TcM Type -- Permit a bang, but discard it -tcHsBangType (L span (HsBangTy b ty)) = tcHsKindedType ty -tcHsBangType ty = tcHsKindedType ty +tcHsBangType (L _ (HsBangTy _ ty)) = tcHsKindedType ty +tcHsBangType ty = tcHsKindedType ty tcHsKindedContext :: LHsContext Name -> TcM ThetaType -- Used when we are expecting a ClassContext (i.e. no implicit params) @@ -235,39 +234,64 @@ tcHsKindedContext hs_theta = addLocM (mapM dsHsLPred) hs_theta --------------------------- kcLiftedType :: LHsType Name -> TcM (LHsType Name) -- The type ty must be a *lifted* *type* -kcLiftedType ty = kcCheckHsType ty liftedTypeKind +kcLiftedType ty = kc_check_lhs_type ty liftedTypeKind --------------------------- kcTypeType :: LHsType Name -> TcM (LHsType Name) -- The type ty must be a *type*, but it can be lifted or -- unlifted or an unboxed tuple. -kcTypeType ty = kcCheckHsType ty openTypeKind +kcTypeType ty = kc_check_lhs_type ty openTypeKind --------------------------- -kcCheckHsType :: LHsType Name -> TcKind -> TcM (LHsType Name) +kcCheckLHsType :: LHsType Name -> TcKind -> TcM (LHsType Name) +kcCheckLHsType ty kind = addKcTypeCtxt ty $ kc_check_lhs_type ty kind + + +kc_check_lhs_type :: LHsType Name -> TcKind -> TcM (LHsType Name) -- Check that the type has the specified kind -- Be sure to use checkExpectedKind, rather than simply unifying -- with OpenTypeKind, because it gives better error messages -kcCheckHsType (L span ty) exp_kind - = setSrcSpan span $ - do { (ty', act_kind) <- add_ctxt ty (kc_hs_type ty) +kc_check_lhs_type (L span ty) exp_kind + = setSrcSpan span $ + do { ty' <- kc_check_hs_type ty exp_kind + ; return (L span ty') } + +kc_check_lhs_types :: [(LHsType Name,TcKind)] -> TcM [LHsType Name] +kc_check_lhs_types tys_w_kinds + = mapM kc_arg tys_w_kinds + where + kc_arg (arg, arg_kind) = kc_check_lhs_type arg arg_kind + + +--------------------------- +kc_check_hs_type :: HsType Name -> TcKind -> TcM (HsType Name) + +-- First some special cases for better error messages +-- when we know the expected kind +kc_check_hs_type (HsParTy ty) exp_kind + = do { ty' <- kc_check_lhs_type ty exp_kind; return (HsParTy ty') } + +kc_check_hs_type ty@(HsAppTy ty1 ty2) exp_kind + = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 ty2 + ; (fun_ty', fun_kind) <- kc_lhs_type fun_ty + ; arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind + ; return (mkHsAppTys fun_ty' arg_tys') } + +kc_check_hs_type ty@(HsPredTy (HsClassP cls tys)) exp_kind + = do { cls_kind <- kcClass cls + ; tys' <- kcCheckApps cls cls_kind tys ty exp_kind + ; return (HsPredTy (HsClassP cls tys')) } + +-- This is the general case: infer the kind and compare +kc_check_hs_type ty exp_kind + = do { (ty', act_kind) <- kc_hs_type ty -- Add the context round the inner check only -- because checkExpectedKind already mentions -- 'ty' by name in any error message ; checkExpectedKind (strip ty) act_kind exp_kind - ; return (L span ty') } + ; return ty' } where - -- Wrap a context around only if we want to show that contexts. - add_ctxt (HsPredTy p) thing = thing - -- Omit invisble ones and ones user's won't grok (HsPred p). - add_ctxt (HsForAllTy _ _ (L _ []) _) thing = thing - -- Omit wrapping if the theta-part is empty - -- Reason: the recursive call to kcLiftedType, in the ForAllTy - -- case of kc_hs_type, will do the wrapping instead - -- and we don't want to duplicate - add_ctxt other_ty thing = addErrCtxt (typeCtxt other_ty) thing - -- We infer the kind of the type, and then complain if it's -- not right. But we don't want to complain about -- (ty) or !(ty) or forall a. ty @@ -276,14 +300,23 @@ kcCheckHsType (L span ty) exp_kind strip (HsBangTy _ (L _ ty)) = strip ty strip (HsForAllTy _ _ _ (L _ ty)) = strip ty strip ty = ty + \end{code} Here comes the main function \begin{code} -kcHsType :: LHsType Name -> TcM (LHsType Name, TcKind) -kcHsType ty = wrapLocFstM kc_hs_type ty --- kcHsType *returns* the kind of the type, rather than taking an expected +kcLHsType :: LHsType Name -> TcM (LHsType Name, TcKind) +-- Called from outside: set the context +kcLHsType ty = addKcTypeCtxt ty (kc_lhs_type ty) + +kc_lhs_type :: LHsType Name -> TcM (LHsType Name, TcKind) +kc_lhs_type (L span ty) + = setSrcSpan span $ + do { (ty', kind) <- kc_hs_type ty + ; return (L span ty', kind) } + +-- kc_hs_type *returns* the kind of the type, rather than taking an expected -- kind as argument as tcExpr does. -- Reasons: -- (a) the kind of (->) is @@ -293,8 +326,9 @@ kcHsType ty = wrapLocFstM kc_hs_type ty -- -- The translated type has explicitly-kinded type-variable binders +kc_hs_type :: HsType Name -> TcM (HsType Name, TcKind) kc_hs_type (HsParTy ty) = do - (ty', kind) <- kcHsType ty + (ty', kind) <- kc_lhs_type ty return (HsParTy ty', kind) kc_hs_type (HsTyVar name) = do @@ -313,7 +347,7 @@ kc_hs_type (HsNumTy n) = return (HsNumTy n, liftedTypeKind) kc_hs_type (HsKindSig ty k) = do - ty' <- kcCheckHsType ty k + ty' <- kc_check_lhs_type ty k return (HsKindSig ty' k, k) kc_hs_type (HsTupleTy Boxed tys) = do @@ -325,28 +359,23 @@ kc_hs_type (HsTupleTy Unboxed tys) = do return (HsTupleTy Unboxed tys', ubxTupleKind) kc_hs_type (HsFunTy ty1 ty2) = do - ty1' <- kcCheckHsType ty1 argTypeKind + ty1' <- kc_check_lhs_type ty1 argTypeKind ty2' <- kcTypeType ty2 return (HsFunTy ty1' ty2', liftedTypeKind) -kc_hs_type ty@(HsOpTy ty1 op ty2) = do +kc_hs_type (HsOpTy ty1 op ty2) = do op_kind <- addLocM kcTyVar op - ([ty1',ty2'], res_kind) <- kcApps op_kind (ppr op) [ty1,ty2] + ([ty1',ty2'], res_kind) <- kcApps op op_kind [ty1,ty2] return (HsOpTy ty1' op ty2', res_kind) -kc_hs_type ty@(HsAppTy ty1 ty2) = do - (fun_ty', fun_kind) <- kcHsType fun_ty - ((arg_ty':arg_tys'), res_kind) <- kcApps fun_kind (ppr fun_ty) arg_tys - return (foldl mk_app (HsAppTy fun_ty' arg_ty') arg_tys', res_kind) +kc_hs_type (HsAppTy ty1 ty2) = do + (fun_ty', fun_kind) <- kc_lhs_type fun_ty + (arg_tys', res_kind) <- kcApps fun_ty fun_kind arg_tys + return (mkHsAppTys fun_ty' arg_tys', res_kind) where - (fun_ty, arg_tys) = split ty1 [ty2] - split (L _ (HsAppTy f a)) as = split f (a:as) - split f as = (f,as) - mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of - -- the application; they are - -- never used + (fun_ty, arg_tys) = splitHsAppTys ty1 ty2 -kc_hs_type ty@(HsPredTy (HsEqualP _ _)) +kc_hs_type (HsPredTy (HsEqualP _ _)) = wrongEqualityErr kc_hs_type (HsPredTy pred) = do @@ -369,11 +398,11 @@ kc_hs_type (HsForAllTy exp tv_names context ty) ; return (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) } kc_hs_type (HsBangTy b ty) = do - (ty', kind) <- kcHsType ty + (ty', kind) <- kc_lhs_type ty return (HsBangTy b ty', kind) kc_hs_type ty@(HsSpliceTy _) - = failWithTc (ptext SLIT("Unexpected type splice:") <+> ppr ty) + = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) -- remove the doc nodes here, no need to worry about the location since -- its the same for a doc node and it's child type node @@ -381,26 +410,54 @@ kc_hs_type (HsDocTy ty _) = kc_hs_type (unLoc ty) --------------------------- -kcApps :: TcKind -- Function kind - -> SDoc -- Function +kcApps :: Outputable a + => a + -> TcKind -- Function kind -> [LHsType Name] -- Arg types -> TcM ([LHsType Name], TcKind) -- Kind-checked args -kcApps fun_kind ppr_fun args = do - (arg_kinds, res_kind) <- split_fk fun_kind (length args) - args' <- zipWithM kc_arg args arg_kinds - return (args', res_kind) +kcApps the_fun fun_kind args + = do { (args_w_kinds, res_kind) <- splitFunKind the_fun fun_kind args + ; args' <- kc_check_lhs_types args_w_kinds + ; return (args', res_kind) } + +kcCheckApps :: Outputable a => a -> TcKind -> [LHsType Name] + -> HsType Name -- The type being checked (for err messages only) + -> TcKind -- Expected kind + -> TcM [LHsType Name] +kcCheckApps the_fun fun_kind args ty exp_kind + = do { (args_w_kinds, res_kind) <- splitFunKind the_fun fun_kind args + ; checkExpectedKind ty res_kind exp_kind + -- Check the result kind *before* checking argument kinds + -- This improves error message; Trac #2994 + ; kc_check_lhs_types args_w_kinds } + +splitHsAppTys :: LHsType Name -> LHsType Name -> (LHsType Name, [LHsType Name]) +splitHsAppTys fun_ty arg_ty = split fun_ty [arg_ty] where - split_fk fk 0 = return ([], fk) - split_fk fk n = do mb_fk <- unifyFunKind fk - case mb_fk of - Nothing -> failWithTc too_many_args - Just (ak,fk') -> do (aks, rk) <- split_fk fk' (n-1) - return (ak:aks, rk) + split (L _ (HsAppTy f a)) as = split f (a:as) + split f as = (f,as) - kc_arg arg arg_kind = kcCheckHsType arg arg_kind +mkHsAppTys :: LHsType Name -> [LHsType Name] -> HsType Name +mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty) +mkHsAppTys fun_ty (arg_ty:arg_tys) + = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys + where + mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of + -- the application; they are + -- never used - too_many_args = ptext SLIT("Kind error:") <+> quotes ppr_fun <+> - ptext SLIT("is applied to too many type arguments") +--------------------------- +splitFunKind :: Outputable a => a -> TcKind -> [b] -> TcM ([(b,TcKind)], TcKind) +splitFunKind _ fk [] = return ([], fk) +splitFunKind the_fun fk (arg:args) + = do { mb_fk <- unifyFunKind fk + ; case mb_fk of + Nothing -> failWithTc too_many_args + Just (ak,fk') -> do { (aks, rk) <- splitFunKind the_fun fk' args + ; return ((arg,ak):aks, rk) } } + where + too_many_args = quotes (ppr the_fun) <+> + ptext (sLit "is applied to too many type arguments") --------------------------- kcHsContext :: LHsContext Name -> TcM (LHsContext Name) @@ -419,19 +476,19 @@ kcHsPred pred = do -- Checks that the result is of kind liftedType kc_pred :: HsPred Name -> TcM (HsPred Name, TcKind) -- Does *not* check for a saturated -- application (reason: used from TcDeriv) -kc_pred pred@(HsIParam name ty) - = do { (ty', kind) <- kcHsType ty +kc_pred (HsIParam name ty) + = do { (ty', kind) <- kc_lhs_type ty ; return (HsIParam name ty', kind) } -kc_pred pred@(HsClassP cls tys) +kc_pred (HsClassP cls tys) = do { kind <- kcClass cls - ; (tys', res_kind) <- kcApps kind (ppr cls) tys + ; (tys', res_kind) <- kcApps cls kind tys ; return (HsClassP cls tys', res_kind) } -kc_pred pred@(HsEqualP ty1 ty2) - = do { (ty1', kind1) <- kcHsType ty1 +kc_pred (HsEqualP ty1 ty2) + = do { (ty1', kind1) <- kc_lhs_type ty1 -- ; checkExpectedKind ty1 kind1 liftedTypeKind - ; (ty2', kind2) <- kcHsType ty2 + ; (ty2', kind2) <- kc_lhs_type ty2 -- ; checkExpectedKind ty2 kind2 liftedTypeKind ; checkExpectedKind ty2 kind2 kind1 ; return (HsEqualP ty1' ty2', liftedTypeKind) @@ -447,7 +504,7 @@ kcTyVar name = do -- Could be a tyvar or a tycon ATyVar _ ty -> return (typeKind ty) AThing kind -> return kind AGlobal (ATyCon tc) -> return (tyConKind tc) - other -> wrongThingErr "type" thing name + _ -> wrongThingErr "type" thing name kcClass :: Name -> TcM TcKind kcClass cls = do -- Must be a class @@ -455,7 +512,7 @@ kcClass cls = do -- Must be a class case thing of AThing kind -> return kind AGlobal (AClass cls) -> return (tyConKind (classTyCon cls)) - other -> wrongThingErr "class" thing cls + _ -> wrongThingErr "class" thing cls \end{code} @@ -480,16 +537,17 @@ dsHsType :: LHsType Name -> TcM Type -- All HsTyVarBndrs in the intput type are kind-annotated dsHsType ty = ds_type (unLoc ty) -ds_type ty@(HsTyVar name) +ds_type :: HsType Name -> TcM Type +ds_type ty@(HsTyVar _) = ds_app ty [] ds_type (HsParTy ty) -- Remove the parentheses markers = dsHsType ty ds_type ty@(HsBangTy _ _) -- No bangs should be here - = failWithTc (ptext SLIT("Unexpected strictness annotation:") <+> ppr ty) + = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty) -ds_type (HsKindSig ty k) +ds_type (HsKindSig ty _) = dsHsType ty -- Kind checking done already ds_type (HsListTy ty) = do @@ -531,7 +589,7 @@ ds_type (HsPredTy pred) = do pred' <- dsHsPred pred return (mkPredTy pred') -ds_type full_ty@(HsForAllTy exp tv_names ctxt ty) +ds_type (HsForAllTy _ tv_names ctxt ty) = tcTyVarBndrs tv_names $ \ tyvars -> do theta <- mapM dsHsLPred (unLoc ctxt) tau <- dsHsType ty @@ -542,6 +600,7 @@ ds_type (HsSpliceTy {}) = panic "ds_type: HsSpliceTy" ds_type (HsDocTy ty _) -- Remove the doc comment = dsHsType ty +dsHsTypes :: [LHsType Name] -> TcM [Type] dsHsTypes arg_tys = mapM dsHsType arg_tys \end{code} @@ -557,16 +616,16 @@ ds_app ty tys = do arg_tys <- dsHsTypes tys case ty of HsTyVar fun -> ds_var_app fun arg_tys - other -> do fun_ty <- ds_type ty + _ -> do fun_ty <- ds_type ty return (mkAppTys fun_ty arg_tys) ds_var_app :: Name -> [Type] -> TcM Type ds_var_app name arg_tys = do thing <- tcLookup name case thing of - ATyVar _ ty -> return (mkAppTys ty arg_tys) + ATyVar _ ty -> return (mkAppTys ty arg_tys) AGlobal (ATyCon tc) -> return (mkTyConApp tc arg_tys) - other -> wrongThingErr "type" thing name + _ -> wrongThingErr "type" thing name \end{code} @@ -577,12 +636,13 @@ Contexts dsHsLPred :: LHsPred Name -> TcM PredType dsHsLPred pred = dsHsPred (unLoc pred) -dsHsPred pred@(HsClassP class_name tys) +dsHsPred :: HsPred Name -> TcM PredType +dsHsPred (HsClassP class_name tys) = do { arg_tys <- dsHsTypes tys ; clas <- tcLookupClass class_name ; return (ClassP clas arg_tys) } -dsHsPred pred@(HsEqualP ty1 ty2) +dsHsPred (HsEqualP ty1 ty2) = do { arg_ty1 <- dsHsType ty1 ; arg_ty2 <- dsHsType ty2 ; return (EqPred arg_ty1 arg_ty2) @@ -605,23 +665,31 @@ tcLHsConResTy (L span res_ty) ; thing <- tcLookup tc_name ; case thing of AGlobal (ATyCon tc) -> return (tc, args') - other -> failWithTc (badGadtDecl res_ty) } - other -> failWithTc (badGadtDecl res_ty) + _ -> failWithTc (badGadtDecl res_ty) } + _ -> failWithTc (badGadtDecl res_ty) where -- We can't call dsHsType on res_ty, and then do tcSplitTyConApp_maybe -- because that causes a black hole, and for good reason. Building -- the type means expanding type synonyms, and we can't do that -- inside the "knot". So we have to work by steam. - get_args (HsAppTy (L _ fun) arg) args = get_args fun (arg:args) - get_args (HsParTy (L _ ty)) args = get_args ty args - get_args (HsOpTy ty1 (L span tc) ty2) args = (HsTyVar tc, ty1:ty2:args) - get_args ty args = (ty, args) + get_args (HsAppTy (L _ fun) arg) args = get_args fun (arg:args) + get_args (HsParTy (L _ ty)) args = get_args ty args + get_args (HsOpTy ty1 (L _ tc) ty2) args = (HsTyVar tc, ty1:ty2:args) + get_args ty args = (ty, args) +badGadtDecl :: HsType Name -> SDoc badGadtDecl ty - = hang (ptext SLIT("Malformed constructor result type:")) + = hang (ptext (sLit "Malformed constructor result type:")) 2 (ppr ty) -typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty) +addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a + -- Wrap a context around only if we want to show that contexts. +addKcTypeCtxt (L _ (HsPredTy _)) thing = thing + -- Omit invisble ones and ones user's won't grok (HsPred p). +addKcTypeCtxt (L _ other_ty) thing = addErrCtxt (typeCtxt other_ty) thing + +typeCtxt :: HsType Name -> SDoc +typeCtxt ty = ptext (sLit "In the type") <+> quotes (ppr ty) \end{code} %************************************************************************ @@ -657,7 +725,7 @@ tcTyVarBndrs bndrs thing_inside = do where zonk (KindedTyVar name kind) = do { kind' <- zonkTcKindToKind kind ; return (mkTyVar name kind') } - zonk (UserTyVar name) = WARN( True, ptext SLIT("Un-kinded tyvar") <+> ppr name ) + zonk (UserTyVar name) = WARN( True, ptext (sLit "Un-kinded tyvar") <+> ppr name ) return (mkTyVar name liftedTypeKind) ----------------------------------- @@ -674,23 +742,43 @@ tcDataKindSig (Just kind) ; us <- newUniqueSupply ; let uniqs = uniqsFromSupply us ; return [ mk_tv span uniq str kind - | ((kind, str), uniq) <- arg_kinds `zip` names `zip` uniqs ] } + | ((kind, str), uniq) <- arg_kinds `zip` dnames `zip` uniqs ] } where (arg_kinds, res_kind) = splitKindFunTys kind mk_tv loc uniq str kind = mkTyVar name kind where name = mkInternalName uniq occ loc occ = mkOccName tvName str + + dnames = map ('$' :) names -- Note [Avoid name clashes for associated data types] - names :: [String] -- a,b,c...aa,ab,ac etc + names :: [String] names = [ c:cs | cs <- "" : names, c <- ['a'..'z'] ] badKindSig :: Kind -> SDoc badKindSig kind - = hang (ptext SLIT("Kind signature on data type declaration has non-* return kind")) + = hang (ptext (sLit "Kind signature on data type declaration has non-* return kind")) 2 (ppr kind) \end{code} +Note [Avoid name clashes for associated data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider class C a b where + data D b :: * -> * +When typechecking the decl for D, we'll invent an extra type variable for D, +to fill out its kind. We *don't* want this type variable to be 'a', because +in an .hi file we'd get + class C a b where + data D b a +which makes it look as if there are *two* type indices. But there aren't! +So we use $a instead, which cannot clash with a user-written type variable. +Remember that type variable binders in interface files are just FastStrings, +not proper Names. + +(The tidying phase can't help here because we don't tidy TyCons. Another +alternative would be to record the number of indexing parameters in the +interface file.) + %************************************************************************ %* * @@ -761,16 +849,17 @@ tcPatSig :: UserTypeCtxt -> LHsType Name -> BoxySigmaType -> TcM (TcType, -- The type to use for "inside" the signature - [(Name,TcType)]) -- The new bit of type environment, binding + [(Name, TcType)], -- The new bit of type environment, binding -- the scoped type variables + CoercionI) -- Coercion due to unification with actual ty tcPatSig ctxt sig res_ty = do { (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig ; if null sig_tvs then do { -- The type signature binds no type variables, -- and hence is rigid, so use it to zap the res_ty - boxyUnify sig_ty res_ty - ; return (sig_ty, []) + coi <- boxyUnify sig_ty res_ty + ; return (sig_ty, [], coi) } else do { -- Type signature binds at least one scoped type variable @@ -781,7 +870,7 @@ tcPatSig ctxt sig res_ty -- So we just have an ASSERT here ; let in_pat_bind = case ctxt of BindPatSigCtxt -> True - other -> False + _ -> False ; ASSERT( not in_pat_bind || null sig_tvs ) return () -- Check that pat_ty is rigid @@ -793,7 +882,8 @@ tcPatSig ctxt sig res_ty -- unifying, and reading out the results. -- This is a strictly local operation. ; box_tvs <- mapM tcInstBoxyTyVar sig_tvs - ; boxyUnify (substTyWith sig_tvs (mkTyVarTys box_tvs) sig_ty) res_ty + ; coi <- boxyUnify (substTyWith sig_tvs (mkTyVarTys box_tvs) sig_ty) + res_ty ; sig_tv_tys <- mapM readFilledBox box_tvs -- Check that each is bound to a distinct type variable, @@ -803,10 +893,10 @@ tcPatSig ctxt sig res_ty ; check binds_in_scope tv_binds -- Phew! - ; return (res_ty, tv_binds) + ; return (res_ty, tv_binds, coi) } } where - check in_scope [] = return () + check _ [] = return () check in_scope ((n,ty):rest) = do { check_one in_scope n ty ; check ((n,ty):in_scope) rest } @@ -832,32 +922,35 @@ tcPatSig ctxt sig res_ty \begin{code} pprHsSigCtxt :: UserTypeCtxt -> LHsType Name -> SDoc -pprHsSigCtxt ctxt hs_ty = vcat [ ptext SLIT("In") <+> pprUserTypeCtxt ctxt <> colon, +pprHsSigCtxt ctxt hs_ty = vcat [ ptext (sLit "In") <+> pprUserTypeCtxt ctxt <> colon, nest 2 (pp_sig ctxt) ] where pp_sig (FunSigCtxt n) = pp_n_colon n pp_sig (ConArgCtxt n) = pp_n_colon n pp_sig (ForSigCtxt n) = pp_n_colon n - pp_sig other = ppr (unLoc hs_ty) + pp_sig _ = ppr (unLoc hs_ty) pp_n_colon n = ppr n <+> dcolon <+> ppr (unLoc hs_ty) - +wobblyPatSig :: [Var] -> SDoc wobblyPatSig sig_tvs - = hang (ptext SLIT("A pattern type signature cannot bind scoped type variables") + = hang (ptext (sLit "A pattern type signature cannot bind scoped type variables") <+> pprQuotedList sig_tvs) - 2 (ptext SLIT("unless the pattern has a rigid type context")) + 2 (ptext (sLit "unless the pattern has a rigid type context")) +scopedNonVar :: Name -> Type -> SDoc scopedNonVar n ty - = vcat [sep [ptext SLIT("The scoped type variable") <+> quotes (ppr n), - nest 2 (ptext SLIT("is bound to the type") <+> quotes (ppr ty))], - nest 2 (ptext SLIT("You can only bind scoped type variables to type variables"))] + = vcat [sep [ptext (sLit "The scoped type variable") <+> quotes (ppr n), + nest 2 (ptext (sLit "is bound to the type") <+> quotes (ppr ty))], + nest 2 (ptext (sLit "You can only bind scoped type variables to type variables"))] -dupInScope n n' ty - = hang (ptext SLIT("The scoped type variables") <+> quotes (ppr n) <+> ptext SLIT("and") <+> quotes (ppr n')) - 2 (vcat [ptext SLIT("are bound to the same type (variable)"), - ptext SLIT("Distinct scoped type variables must be distinct")]) +dupInScope :: Name -> Name -> Type -> SDoc +dupInScope n n' _ + = hang (ptext (sLit "The scoped type variables") <+> quotes (ppr n) <+> ptext (sLit "and") <+> quotes (ppr n')) + 2 (vcat [ptext (sLit "are bound to the same type (variable)"), + ptext (sLit "Distinct scoped type variables must be distinct")]) +wrongEqualityErr :: TcM (HsType Name, TcKind) wrongEqualityErr = failWithTc (text "Equality predicate used as a type") \end{code}