diff options
| author | Jose Pedro Magalhaes <jpm@cs.uu.nl> | 2011-11-11 09:07:11 +0000 |
|---|---|---|
| committer | Jose Pedro Magalhaes <jpm@cs.uu.nl> | 2011-11-11 09:09:23 +0000 |
| commit | 09015be8d580bc33f5f1960c8e31d00ba7a459a1 (patch) | |
| tree | c7efea03f85327c35d875257679a73520408c3e9 | |
| parent | fd742437b9e5933da145aea1e80766990c649a15 (diff) | |
| download | haskell-09015be8d580bc33f5f1960c8e31d00ba7a459a1.tar.gz | |
New kind-polymorphic core
This big patch implements a kind-polymorphic core for GHC. The current
implementation focuses on making sure that all kind-monomorphic programs still
work in the new core; it is not yet guaranteed that kind-polymorphic programs
(using the new -XPolyKinds flag) will work.
For more information, see http://haskell.org/haskellwiki/GHC/Kinds
88 files changed, 3847 insertions, 2058 deletions
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index a7184e01ed..c5f56d8712 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -1024,7 +1024,7 @@ voidArgId -- :: State# RealWorld coercionTokenId :: Id -- :: () ~ () coercionTokenId -- Used to replace Coercion terms when we go to STG = pcMiscPrelId coercionTokenName - (mkTyConApp eqPrimTyCon [unitTy, unitTy]) + (mkTyConApp eqPrimTyCon [liftedTypeKind, unitTy, unitTy]) noCafIdInfo \end{code} diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index a48a7d44bd..fa8635091d 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -53,6 +53,7 @@ module OccName ( mkDFunOcc, mkTupleOcc, setOccNameSpace, + demoteOccName, -- ** Derived 'OccName's isDerivedOccName, @@ -204,8 +205,35 @@ pprNameSpaceBrief DataName = char 'd' pprNameSpaceBrief VarName = char 'v' pprNameSpaceBrief TvName = ptext (sLit "tv") pprNameSpaceBrief TcClsName = ptext (sLit "tc") + +-- demoteNameSpace lowers the NameSpace if possible. We can not know +-- in advance, since a TvName can appear in an HsTyVar. +-- see Note [Demotion] +demoteNameSpace :: NameSpace -> Maybe NameSpace +demoteNameSpace VarName = Nothing +demoteNameSpace DataName = Nothing +demoteNameSpace TvName = Nothing +demoteNameSpace TcClsName = Just DataName \end{code} +Note [Demotion] +~~~~~~~~~~~~~~~ + +When the user writes: + data Nat = Zero | Succ Nat + foo :: f Zero -> Int + +'Zero' in the type signature of 'foo' is parsed as: + HsTyVar ("Zero", TcClsName) + +When the renamer hits this occurence of 'Zero' it's going to realise +that it's not in scope. But because it is renaming a type, it knows +that 'Zero' might be a promoted data constructor, so it will demote +its namespace to DataName and do a second lookup. + +The final result (after the renamer) will be: + HsTyVar ("Zero", DataName) + %************************************************************************ %* * @@ -316,6 +344,13 @@ mkClsOcc = mkOccName clsName mkClsOccFS :: FastString -> OccName mkClsOccFS = mkOccNameFS clsName + +-- demoteOccName lowers the Namespace of OccName. +-- see Note [Demotion] +demoteOccName :: OccName -> Maybe OccName +demoteOccName (OccName space name) = do + space' <- demoteNameSpace space + return $ OccName space' name \end{code} diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index ba09d923b8..0353e65d04 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -40,7 +40,7 @@ module RdrName ( nameRdrName, getRdrName, -- ** Destruction - rdrNameOcc, rdrNameSpace, setRdrNameSpace, + rdrNameOcc, rdrNameSpace, setRdrNameSpace, demoteRdrName, isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, @@ -159,6 +159,14 @@ setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) setRdrNameSpace (Exact n) ns = ASSERT( isExternalName n ) Orig (nameModule n) (setOccNameSpace ns (nameOccName n)) + +-- demoteRdrName lowers the NameSpace of RdrName. +-- see Note [Demotion] in OccName +demoteRdrName :: RdrName -> Maybe RdrName +demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) +demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) +demoteRdrName (Orig _ _) = panic "demoteRdrName" +demoteRdrName (Exact _) = panic "demoteRdrName" \end{code} \begin{code} diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index a923f4d9dd..1692520858 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -39,7 +39,7 @@ module Var ( -- * The main data type and synonyms - Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EqVar, EvId, IpId, + Var, TyVar, CoVar, Id, KindVar, DictId, DFunId, EvVar, EqVar, EvId, IpId, -- ** Taking 'Var's apart varName, varUnique, varType, @@ -60,20 +60,21 @@ module Var ( mustHaveLocalBinding, -- ** Constructing 'TyVar's - mkTyVar, mkTcTyVar, + mkTyVar, mkTcTyVar, mkKindVar, -- ** Taking 'TyVar's apart tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, -- ** Modifying 'TyVar's - setTyVarName, setTyVarUnique, setTyVarKind + setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind, + updateTyVarKindM ) where #include "HsVersions.h" #include "Typeable.h" -import {-# SOURCE #-} TypeRep( Type, Kind ) +import {-# SOURCE #-} TypeRep( Type, Kind, SuperKind ) import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails ) import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo, pprIdDetails ) @@ -98,7 +99,10 @@ import Data.Data \begin{code} type Id = Var -- A term-level identifier -type TyVar = Var + +type TyVar = Var -- Type *or* kind variable +type KindVar = Var -- Definitely a kind variable + -- See Note [Kind and type variables] -- See Note [Evidence: EvIds and CoVars] type EvId = Id -- Term-level evidence: DictId, IpId, or EqVar @@ -125,6 +129,16 @@ Note [Evidence: EvIds and CoVars] * Only CoVars can occur in Coercions (but NB the LCoercion hack; see Note [LCoercions] in Coercion). +Note [Kind and type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before kind polymorphism, TyVar were used to mean type variables. Now +they are use to mean kind *or* type variables. KindVar is used when we +know for sure that it is a kind variable. In future, we might want to +go over the whole compiler code to use: + - KiTyVar to mean kind or type variables + - TyVar to mean type variables only + - KindVar to mean kind variables + %************************************************************************ %* * @@ -142,7 +156,8 @@ in its @VarDetails@. -- | Essentially a typed 'Name', that may also contain some additional information -- about the 'Var' and it's use sites. data Var - = TyVar { + = TyVar { -- type and kind variables + -- see Note [Kind and type variables] varName :: !Name, realUnique :: FastInt, -- Key for fast comparison -- Identical to the Unique in the name, @@ -195,7 +210,8 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds \begin{code} instance Outputable Var where - ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var)) + ppr var = ifPprDebug (text "(") <+> ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var)) + <+> ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")") ppr_debug :: Var -> SDoc ppr_debug (TyVar {}) = ptext (sLit "tv") @@ -255,7 +271,7 @@ setVarType id ty = id { varType = ty } %************************************************************************ %* * -\subsection{Type variables} +\subsection{Type and kind variables} %* * %************************************************************************ @@ -274,6 +290,14 @@ setTyVarName = setVarName setTyVarKind :: TyVar -> Kind -> TyVar setTyVarKind tv k = tv {varType = k} + +updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar +updateTyVarKind update tv = tv {varType = update (tyVarKind tv)} + +updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar +updateTyVarKindM update tv + = do { k' <- update (tyVarKind tv) + ; return $ tv {varType = k'} } \end{code} \begin{code} @@ -298,6 +322,15 @@ tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var) setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar setTcTyVarDetails tv details = tv { tc_tv_details = details } + +mkKindVar :: Name -> SuperKind -> KindVar +-- mkKindVar take a SuperKind as argument because we don't have access +-- to tySuperKind here. +mkKindVar name kind = TyVar + { varName = name + , realUnique = getKeyFastInt (nameUnique name) + , varType = kind } + \end{code} %************************************************************************ diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 9351da1716..1df84134a9 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -218,11 +218,13 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) %************************************************************************ \begin{code} -type InType = Type -- Substitution not yet applied +--type InKind = Kind -- Substitution not yet applied +type InType = Type type InCoercion = Coercion type InVar = Var type InTyVar = TyVar +type OutKind = Kind -- Substitution has been applied to this type OutType = Type -- Substitution has been applied to this type OutCoercion = Coercion type OutVar = Var @@ -296,19 +298,6 @@ lintCoreExpr (Let (Rec pairs) body) (_, dups) = removeDups compare bndrs lintCoreExpr e@(App _ _) - | Var x <- fun -- Greivous hack for Eq# construction: Eq# may have type arguments - -- of kind (* -> *) but its type insists on *. When we have polymorphic kinds, - -- we should do this properly - , Just dc <- isDataConWorkId_maybe x - , dc == eqBoxDataCon - , [Type arg_ty1, Type arg_ty2, co_e] <- args - = do arg_kind1 <- lintType arg_ty1 - arg_kind2 <- lintType arg_ty2 - unless (arg_kind1 `eqKind` arg_kind2) - (addErrL (mkEqBoxKindErrMsg arg_ty1 arg_ty2)) - - lintCoreArg (mkCoercionType arg_ty1 arg_ty2 `mkFunTy` mkEqPred (arg_ty1, arg_ty2)) co_e - | otherwise = do { fun_ty <- lintCoreExpr fun ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args } where @@ -370,6 +359,27 @@ lintCoreExpr (Coercion co) ; return (mkCoercionType ty1 ty2) } \end{code} +Note [Kind instantiation in coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider the following coercion axiom: + ax_co [(k_ag :: BOX), (f_aa :: k_ag -> Constraint)] :: T k_ag f_aa ~ f_aa + +Consider the following instantiation: + ax_co <* -> *> <Monad> + +We need to split the co_ax_tvs into kind and type variables in order +to find out the coercion kind instantiations. Those can only be Refl +since we don't have kind coercions. This is just a way to represent +kind instantiation. + +We use the number of kind variables to know how to split the coercions +instantiations between kind coercions and type coercions. We lint the +kind coercions and produce the following substitution which is to be +applied in the type variables: + k_ag ~~> * -> * + + %************************************************************************ %* * \subsection[lintCoreArgs]{lintCoreArgs} @@ -432,10 +442,14 @@ lintValApp arg fun_ty arg_ty checkTyKind :: OutTyVar -> OutType -> LintM () -- Both args have had substitution applied checkTyKind tyvar arg_ty + | isSuperKind tyvar_kind -- kind forall + -- IA0_NOTE: I added this case to handle kind foralls + = lintKind arg_ty -- Arg type might be boxed for a function with an uncommitted -- tyvar; notably this is used so that we can give -- error :: forall a:*. String -> a -- and then apply it to both boxed and unboxed types. + | otherwise -- type forall = do { arg_kind <- lintType arg_ty ; unless (arg_kind `isSubKind` tyvar_kind) (addErrL (mkKindErrMsg tyvar arg_ty)) } @@ -458,6 +472,16 @@ checkTyCoKind tv co checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)] checkTyCoKinds = zipWithM checkTyCoKind +checkKiCoKind :: KindVar -> OutCoercion -> LintM Kind +-- see lintCoercion (AxiomInstCo {}) and Note [Kind instantiation in coercions] +checkKiCoKind kv co + = do { ki <- lintKindCoercion co + ; unless (isSuperKind (tyVarKind kv)) (addErrL (mkTyCoAppErrMsg kv co)) + ; return ki } + +checkKiCoKinds :: [KindVar] -> [OutCoercion] -> LintM [Kind] +checkKiCoKinds = zipWithM checkKiCoKind + checkDeadIdOcc :: Id -> LintM () -- Occurrences of an Id should never be dead.... -- except when we are checking a case pattern @@ -622,11 +646,11 @@ lintAndScopeId id linterF lintInTy :: InType -> LintM OutType -- Check the type, and apply the substitution to it -- See Note [Linting type lets] --- ToDo: check the kind structure of the type lintInTy ty = addLoc (InType ty) $ do { ty' <- applySubstTy ty - ; _ <- lintType ty' + ; k <- lintType ty' + ; lintKind k ; return ty' } lintInCo :: InCoercion -> LintM OutCoercion @@ -639,21 +663,42 @@ lintInCo co ; return co' } ------------------- -lintKind :: Kind -> LintM () --- Check well-formedness of kinds: *, *->*, etc -lintKind (TyConApp tc []) - | tyConKind tc `eqKind` tySuperKind - = return () +lintKind :: OutKind -> LintM () +-- Check well-formedness of kinds: *, *->*, Either * (* -> *), etc lintKind (FunTy k1 k2) = lintKind k1 >> lintKind k2 -lintKind kind + +lintKind kind@(TyConApp tc kis) + = do { unless (tyConArity tc == length kis || isSuperKindTyCon tc) + (addErrL malformed_kind) + ; mapM_ lintKind kis } + where + malformed_kind = hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind)) + +lintKind (TyVarTy kv) = checkTyCoVarInScope kv +lintKind kind = addErrL (hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind))) ------------------- lintTyBndrKind :: OutTyVar -> LintM () -lintTyBndrKind tv = lintKind (tyVarKind tv) +-- Handles both type and kind foralls. +lintTyBndrKind tv = + let ki = tyVarKind tv in + if isSuperKind ki + then return () -- kind forall + else lintKind ki -- type forall ------------------- +lintKindCoercion :: OutCoercion -> LintM OutKind +-- Kind coercions are only reflexivity because they mean kind +-- instantiation. See Note [Kind coercions] in Coercion +lintKindCoercion co + = do { (k1,k2) <- lintCoercion co + ; checkL (k1 `eqKind` k2) + (hang (ptext (sLit "Non-refl kind coercion")) + 2 (ppr co)) + ; return k1 } + lintCoercion :: OutCoercion -> LintM (OutType, OutType) -- Check the kind of a coercion term, returning the kind lintCoercion (Refl ty) @@ -661,9 +706,21 @@ lintCoercion (Refl ty) ; return (ty, ty) } lintCoercion co@(TyConAppCo tc cos) - = do { (ss,ts) <- mapAndUnzipM lintCoercion cos - ; check_co_app co (tyConKind tc) ss - ; return (mkTyConApp tc ss, mkTyConApp tc ts) } + = do -- We use the kind of the type constructor to know how many + -- kind coercions we have (one kind coercion for one kind + -- instantiation). + { let ki | tc `hasKey` funTyConKey && length cos == 2 + = mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind + -- It's a fully applied function, so we must use the + -- most permissive type for the arrow constructor + | otherwise = tyConKind tc + (kvs, _) = splitForAllTys ki + (cokis, cotys) = splitAt (length kvs) cos + -- kis are the kind instantiations of tc + ; kis <- mapM lintKindCoercion cokis + ; (ss,ts) <- mapAndUnzipM lintCoercion cotys + ; check_co_app co ki (kis ++ ss) + ; return (mkTyConApp tc (kis ++ ss), mkTyConApp tc (kis ++ ts)) } lintCoercion co@(AppCo co1 co2) = do { (s1,t1) <- lintCoercion co1 @@ -672,7 +729,9 @@ lintCoercion co@(AppCo co1 co2) ; return (mkAppTy s1 s2, mkAppTy t1 t2) } lintCoercion (ForAllCo v co) - = do { lintKind (tyVarKind v) + = do { let kind = tyVarKind v + -- lintKind when type forall, otherwise we are a kind forall + ; unless (isSuperKind kind) (lintKind kind) ; (s,t) <- addInScopeVar v (lintCoercion co) ; return (ForAllTy v s, ForAllTy v t) } @@ -684,13 +743,21 @@ lintCoercion (CoVarCo cv) = do { checkTyCoVarInScope cv ; return (coVarKind cv) } -lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = tvs +lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = ktvs , co_ax_lhs = lhs - , co_ax_rhs = rhs }) + , co_ax_rhs = rhs }) cos) - = do { (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs cos) - ; return (substTyWith tvs tys1 lhs, - substTyWith tvs tys2 rhs) } + = ASSERT2 (not (any isKiVar tvs), ppr ktvs) + do -- see Note [Kind instantiation in coercions] + { kis <- checkKiCoKinds kvs kcos + ; let tvs' = map (updateTyVarKind (Type.substTy subst)) tvs + subst = zipOpenTvSubst kvs kis + ; (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs' tcos) + ; return (substTyWith ktvs (kis ++ tys1) lhs, + substTyWith ktvs (kis ++ tys2) rhs) } + where + (kvs, tvs) = splitKiTyVars ktvs + (kcos, tcos) = splitAt (length kvs) cos lintCoercion (UnsafeCo ty1 ty2) = do { _k1 <- lintType ty1 @@ -741,20 +808,21 @@ checkTcApp co n ty lintType :: OutType -> LintM Kind lintType (TyVarTy tv) = do { checkTyCoVarInScope tv - ; return (tyVarKind tv) } + ; let kind = tyVarKind tv + ; lintKind kind + ; if (isSuperKind kind) then failWithL msg + else return kind } + where msg = hang (ptext (sLit "Expecting a type, but got a kind")) + 2 (ptext (sLit "Offending kind:") <+> ppr tv) lintType ty@(AppTy t1 t2) = do { k1 <- lintType t1 ; lint_ty_app ty k1 [t2] } lintType ty@(FunTy t1 t2) - = lint_ty_app ty (tyConKind funTyCon) [t1,t2] + = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2] lintType ty@(TyConApp tc tys) - | tc `hasKey` eqPrimTyConKey -- See Note [The ~# TyCon] in TysPrim - = lint_prim_eq_pred ty tys - | tc `hasKey` eqTyConKey - = lint_eq_pred ty tys | tyConHasKind tc = lint_ty_app ty (tyConKind tc) tys | otherwise @@ -766,58 +834,43 @@ lintType (ForAllTy tv ty) ---------------- lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind -lint_ty_app ty k tys - = do { ks <- mapM lintType tys - ; lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k ks } - -lint_eq_pred :: Type -> [OutType] -> LintM Kind -lint_eq_pred ty arg_tys = case arg_tys of - [ty1, ty2] -> do { k1 <- lintType ty1 - ; k2 <- lintType ty2 - ; unless (k1 `eqKind` k2) - (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:") - , nest 2 (ppr ty) ])) - ; return constraintKind } - [ty1] -> do { k1 <- lintType ty1; - return (k1 `mkFunTy` constraintKind) } - [] -> do { return (typeKind ty) } - _ -> failWithL (ptext (sLit "Oversaturated (~) type") <+> ppr ty) - - -lint_prim_eq_pred :: Type -> [OutType] -> LintM Kind -lint_prim_eq_pred ty arg_tys - | [ty1,ty2] <- arg_tys - = do { k1 <- lintType ty1 - ; k2 <- lintType ty2 - ; checkL (k1 `eqKind` k2) - (ptext (sLit "Mismatched arg kinds:") <+> ppr ty) - ; return unliftedTypeKind } - | otherwise - = failWithL (ptext (sLit "Unsaturated ~# type") <+> ppr ty) +lint_ty_app ty k tys = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys ---------------- check_co_app :: Coercion -> Kind -> [OutType] -> LintM () -check_co_app ty k tys - = do { _ <- lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) - k (map typeKind tys) - ; return () } - +check_co_app ty k tys = lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys >> return () + ---------------- -lint_kind_app :: SDoc -> Kind -> [Kind] -> LintM Kind -lint_kind_app doc kfn ks = go kfn ks +lint_kind_app :: SDoc -> Kind -> [OutType] -> LintM Kind +-- Takes care of linting the OutTypes +lint_kind_app doc kfn tys = go kfn tys where - fail_msg = vcat [hang (ptext (sLit "Kind application error in")) 2 doc, - nest 2 (ptext (sLit "Function kind =") <+> ppr kfn), - nest 2 (ptext (sLit "Arg kinds =") <+> ppr ks)] - - go kfn [] = return kfn - go kfn (k:ks) = case splitKindFunTy_maybe kfn of - Nothing -> failWithL fail_msg - Just (kfa, kfb) -> do { unless (k `isSubKind` kfa) - (addErrL fail_msg) - ; go kfb ks } + fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc + , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn) + , nest 2 (ptext (sLit "Arg types =") <+> ppr tys) ] + + go kfn [] = return kfn + go kfn (ty:tys) = + case splitKindFunTy_maybe kfn of + { Nothing -> + case splitForAllTy_maybe kfn of + { Nothing -> failWithL fail_msg + ; Just (kv, body) -> do + -- Something of kind (forall kv. body) gets instantiated + -- with ty. 'kv' is a kind variable and 'ty' is a kind. + { unless (isSuperKind (tyVarKind kv)) (addErrL fail_msg) + ; lintKind ty + ; go (substKiWith [kv] [ty] body) tys } } + ; Just (kfa, kfb) -> do + -- Something of kind (kfa -> kfb) is applied to ty. 'ty' is + -- a type accepting kind 'kfa'. + { k <- lintType ty + ; lintKind kfa + ; unless (k `isSubKind` kfa) (addErrL fail_msg) + ; go kfb tys } } + \end{code} - + %************************************************************************ %* * \subsection[lint-monad]{The Lint monad} @@ -1168,14 +1221,6 @@ mkStrictMsg binder ] -mkEqBoxKindErrMsg :: Type -> Type -> Message -mkEqBoxKindErrMsg ty1 ty2 - = vcat [ptext (sLit "Kinds don't match in type arguments of Eq#:"), - hang (ptext (sLit "Arg type 1:")) - 4 (ppr ty1 <+> dcolon <+> ppr (typeKind ty1)), - hang (ptext (sLit "Arg type 2:")) - 4 (ppr ty2 <+> dcolon <+> ppr (typeKind ty2))] - mkKindErrMsg :: TyVar -> Type -> Message mkKindErrMsg tyvar arg_ty = vcat [ptext (sLit "Kinds don't match in type application:"), diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 6bcf3fbde4..c4b3019485 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -67,6 +67,7 @@ import Util import Pair import Data.Word import Data.Bits +import Data.List ( mapAccumL ) \end{code} @@ -1064,9 +1065,10 @@ dataConInstPat :: [FastString] -- A long enough list of FSs to use for -- -- where the double-primed variables are created with the FastStrings and -- Uniques given as fss and us -dataConInstPat fss uniqs con inst_tys - = (ex_bndrs, arg_ids) - where +dataConInstPat fss uniqs con inst_tys + = ASSERT( univ_tvs `equalLength` inst_tys ) + (ex_bndrs, arg_ids) + where univ_tvs = dataConUnivTyVars con ex_tvs = dataConExTyVars con arg_tys = dataConRepArgTys con @@ -1077,19 +1079,25 @@ dataConInstPat fss uniqs con inst_tys (ex_uniqs, id_uniqs) = splitAt n_ex uniqs (ex_fss, id_fss) = splitAt n_ex fss - -- Make existential type variables - ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs - mk_ex_var uniq fs var = mkTyVar new_name kind + -- Make the instantiating substitution for universals + univ_subst = zipOpenTvSubst univ_tvs inst_tys + + -- Make existential type variables, applyingn and extending the substitution + (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst + (zip3 ex_tvs ex_fss ex_uniqs) + + mk_ex_var :: TvSubst -> (TyVar, FastString, Unique) -> (TvSubst, TyVar) + mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubst subst tv (mkTyVarTy new_tv) + , new_tv) where + new_tv = mkTyVar new_name kind new_name = mkSysTvName uniq fs - kind = tyVarKind var - - -- Make the instantiating substitution - subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs) + kind = Type.substTy subst (tyVarKind tv) -- Make value vars, instantiating types - mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (Type.substTy subst ty) noSrcSpan arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys + mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq + (Type.substTy full_subst ty) noSrcSpan \end{code} %************************************************************************ diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index d941b0a4b1..dd41184994 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -288,8 +288,10 @@ mkIPUnbox ipx = Var x `Cast` mkAxInstCo (ipCoAxiom ip) [ty] \begin{code} mkEqBox :: Coercion -> CoreExpr -mkEqBox co = Var (dataConWorkId eqBoxDataCon) `mkTyApps` [ty1, ty2] `App` Coercion co +mkEqBox co = ASSERT( typeKind ty2 `eqKind` k ) + Var (dataConWorkId eqBoxDataCon) `mkTyApps` [k, ty1, ty2] `App` Coercion co where Pair ty1 ty2 = coercionKind co + k = typeKind ty1 \end{code} diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index e38885ba54..cb12973a60 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -23,6 +23,7 @@ import TyCon -- import Class import TypeRep import Type +import Kind import PprExternalCore () -- Instances import DataCon import Coercion diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 2ba8a23120..c575b68857 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -28,6 +28,7 @@ import Demand import DataCon import TyCon import Type +import Kind import Coercion import StaticFlags import BasicTypes diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 2e721adde8..a9701ff185 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -86,7 +86,6 @@ deSugar hsc_env tcg_rules = rules, tcg_vects = vects, tcg_tcs = tcs, - tcg_clss = clss, tcg_insts = insts, tcg_fam_insts = fam_insts, tcg_hpc = other_hpc_info }) @@ -184,7 +183,6 @@ deSugar hsc_env mg_warns = warns, mg_anns = anns, mg_tcs = tcs, - mg_clss = clss, mg_insts = insts, mg_fam_insts = fam_insts, mg_inst_env = inst_env, diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 628f911308..4b710f67cc 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -53,6 +53,7 @@ import NameEnv import TcType import TyCon import TysWiredIn +import TysPrim ( liftedTypeKindTyConName ) import CoreSyn import MkCore import CoreUtils @@ -81,7 +82,7 @@ dsBracket brack splices where new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices] - do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 } + do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 } do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 } do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } @@ -598,7 +599,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name -> Core TH.Name -> DsM (Core TH.TyVarBndr) repTyVarBndrWithKind (L _ (UserTyVar {})) nm = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm +repTyVarBndrWithKind (L _ (KindedTyVar _ ki _)) nm = repKind ki >>= repKindedTV nm -- represent a type context @@ -684,7 +685,7 @@ repTy (HsTupleTy HsUnboxedTuple tys) = do tys1 <- repLTys tys tcon <- repUnboxedTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) +repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) `nlHsAppTy` ty2) repTy (HsParTy t) = repLTy t repTy (HsKindSig t k) = do @@ -696,17 +697,16 @@ repTy ty = notHandled "Exotic form of type" (ppr ty) -- represent a kind -- -repKind :: Kind -> DsM (Core TH.Kind) +repKind :: LHsKind Name -> DsM (Core TH.Kind) repKind ki - = do { let (kis, ki') = splitKindFunTys ki + = do { let (kis, ki') = splitHsFunType ki ; kis_rep <- mapM repKind kis ; ki'_rep <- repNonArrowKind ki' ; foldrM repArrowK ki'_rep kis_rep } where - repNonArrowKind k | isLiftedTypeKind k = repStarK - | otherwise = notHandled "Exotic form of kind" - (ppr k) + repNonArrowKind (L _ (HsTyVar name)) | name == liftedTypeKindTyConName = repStarK + repNonArrowKind k = notHandled "Exotic form of kind" (ppr k) ----------------------------------------------------------------------------- -- Splices diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 84d0acf316..f521ee6b06 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -45,6 +45,7 @@ import Var import TcRnMonad import TcType import TcMType +import TcHsSyn ( mkZonkTcTyVar ) import TcUnify import TcEnv @@ -1130,7 +1131,7 @@ zonkTerm = foldTermM (TermFoldM zonkRttiType :: TcType -> TcM Type -- Zonk the type, replacing any unbound Meta tyvars -- by skolems, safely out of Meta-tyvar-land -zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta) +zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta mkTyVarTy) where zonk_unbound_meta tv = ASSERT( isTcTyVar tv ) diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index fc33dc125f..6f88319b06 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -27,7 +27,6 @@ import qualified OccName import OccName import SrcLoc import Type -import Coercion import TysWiredIn import BasicTypes as Hs import ForeignCall @@ -204,7 +203,7 @@ cvtDec (ForeignD ford) cvtDec (FamilyD flav tc tvs kind) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs - ; let kind' = fmap cvtKind kind + ; kind' <- cvtMaybeKind kind ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind') } where cvtFamFlavour TypeFam = TypeFamily @@ -785,7 +784,8 @@ cvt_tv (TH.PlainTV nm) } cvt_tv (TH.KindedTV nm ki) = do { nm' <- tName nm - ; returnL $ KindedTyVar nm' (cvtKind ki) + ; ki' <- cvtKind ki + ; returnL $ KindedTyVar nm' ki' placeHolderKind } cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) @@ -842,7 +842,8 @@ cvtType ty SigT ty ki -> do { ty' <- cvtType ty - ; mk_apps (HsKindSig ty' (cvtKind ki)) tys' + ; ki' <- cvtKind ki + ; mk_apps (HsKindSig ty' ki') tys' } _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty)) @@ -859,9 +860,16 @@ split_ty_app ty = go ty [] go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') } go f as = return (f,as) -cvtKind :: TH.Kind -> Type.Kind -cvtKind StarK = liftedTypeKind -cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2) +cvtKind :: TH.Kind -> CvtM (LHsKind RdrName) +cvtKind StarK = returnL (HsTyVar (getRdrName liftedTypeKindTyCon)) +cvtKind (ArrowK k1 k2) = do + k1' <- cvtKind k1 + k2' <- cvtKind k2 + returnL (HsFunTy k1' k2') + +cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName)) +cvtMaybeKind Nothing = return Nothing +cvtMaybeKind (Just ki) = cvtKind ki >>= return . Just ----------------------------------------------------------- diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 9cdc47d3a4..c3728788f1 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -23,6 +23,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) +import HsLit import HsTypes import PprCore () import CoreSyn @@ -461,9 +462,9 @@ data HsWrapper | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint - -- Type abstraction and application - | WpTyLam TyVar -- \a. [] the 'a' is a type variable (not coercion var) - | WpTyApp Type -- [] t the 't' is a type (not coercion) + -- Kind and Type abstraction and application + | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) + | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 480401b84a..ea34e7991c 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -14,7 +14,7 @@ module HsDecls ( -- * Toplevel declarations HsDecl(..), LHsDecl, -- ** Class or type declarations - TyClDecl(..), LTyClDecl, + TyClDecl(..), LTyClDecl, TyClGroup, isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl, isFamInstDecl, tcdName, tyClDeclTyVars, countTyClDecls, @@ -63,7 +63,6 @@ import HsDoc import TyCon import NameSet import Name -import {- Kind parts of -} Type import BasicTypes import Coercion import ForeignCall @@ -431,6 +430,8 @@ Interface file code: -- In both cases, 'tcdVars' collects all variables we need to quantify over. type LTyClDecl name = Located (TyClDecl name) +type TyClGroup name = [LTyClDecl name] -- this is used in TcTyClsDecls to represent + -- strongly connected components of decls -- | A type or class declaration. data TyClDecl name @@ -444,7 +445,7 @@ data TyClDecl name TyFamily { tcdFlavour:: FamilyFlavour, -- type or data tcdLName :: Located name, -- type constructor tcdTyVars :: [LHsTyVarBndr name], -- type variables - tcdKind :: Maybe Kind -- result kind + tcdKind :: Maybe (LHsKind name) -- result kind } @@ -461,7 +462,7 @@ data TyClDecl name tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns. -- See Note [tcdTyVars and tcdTyPats] - tcdKindSig:: Maybe Kind, + tcdKindSig:: Maybe (LHsKind name), -- ^ Optional kind signature. -- -- @(Just k)@ for a GADT-style @data@, or @data @@ -535,14 +536,18 @@ tcdTyPats = Just tys This is a data/type family instance declaration tcdTyVars are fv(tys) - Eg class C a b where - type F a x :: * - instance D p s => C (p,q) [r] where - type F (p,q) x = p -> x - The tcdTyVars of the F instance decl are {p,q,x}, - i.e. not including s, nor r - (and indeed neither s nor should be mentioned - on the RHS of the F instance decl; Trac #5515) + Eg class C s t where + type F t p :: * + instance C w (a,b) where + type F (a,b) x = x->a + The tcdTyVars of the F decl are {a,b,x}, even though the F decl + is nested inside the 'instance' decl. + + However after the renamer, the uniques will match up: + instance C w7 (a8,b9) where + type F (a8,b9) x10 = x10->a8 + so that we can compare the type patter in the 'instance' decl and + in the associated 'type' decl ------------------------------ Simple classifiers @@ -631,7 +636,7 @@ instance OutputableBndr name pp_kind = case mb_kind of Nothing -> empty - Just kind -> dcolon <+> pprKind kind + Just kind -> dcolon <+> ppr kind ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats, tcdSynRhs = mono_ty}) @@ -653,7 +658,7 @@ instance OutputableBndr name derivings where ppr_sigx Nothing = empty - ppr_sigx (Just kind) = dcolon <+> pprKind kind + ppr_sigx (Just kind) = dcolon <+> ppr kind ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFDs = fds, diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 869532e858..7b814e14bb 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -1197,7 +1197,8 @@ data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] | DecBrL [LHsDecl id] -- [d| decls |]; result of parser | DecBrG (HsGroup id) -- [d| decls |]; result of renamer | TypBr (LHsType id) -- [t| type |] - | VarBr id -- 'x, ''T + | VarBr Bool id -- True: 'x, False: ''T + -- (The Bool flag is used only in pprHsBracket) deriving (Data, Typeable) instance OutputableBndr id => Outputable (HsBracket id) where @@ -1210,11 +1211,8 @@ pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds)) pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) -pprHsBracket (VarBr n) = char '\'' <> ppr n --- Infelicity: can't show ' vs '', because --- we can't ask n what its OccName is, because the --- pretty-printer for HsExpr doesn't ask for NamedThings --- But the pretty-printer for names will show the OccName class +pprHsBracket (VarBr True n) = char '\'' <> ppr n +pprHsBracket (VarBr False n) = ptext (sLit "''") <> ppr n thBrackets :: SDoc -> SDoc -> SDoc thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot index 4dff75c802..6666243264 100644 --- a/compiler/hsSyn/HsExpr.lhs-boot +++ b/compiler/hsSyn/HsExpr.lhs-boot @@ -1,4 +1,5 @@ \begin{code} +{-# LANGUAGE KindSignatures #-} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and @@ -13,11 +14,12 @@ import Outputable ( SDoc, OutputableBndr ) import {-# SOURCE #-} HsPat ( LPat ) import Data.Data - -data HsExpr i -data HsSplice i -data MatchGroup a -data GRHSs a + +-- IA0_NOTE: We need kind annotations because of kind polymorphism +data HsExpr (i :: *) +data HsSplice (i :: *) +data MatchGroup (a :: *) +data GRHSs (a :: *) instance Typeable1 HsSplice instance Data i => Data (HsSplice i) diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index b8e4b11e6b..efa61dde67 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -20,8 +20,7 @@ module HsLit where import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr ) import BasicTypes ( FractionalLit(..) ) -import HsTypes ( PostTcType ) -import Type ( Type ) +import Type ( Type, Kind ) import Outputable import FastString @@ -31,6 +30,26 @@ import Data.Data %************************************************************************ %* * +\subsection{Annotating the syntax} +%* * +%************************************************************************ + +\begin{code} +type PostTcKind = Kind +type PostTcType = Type -- Used for slots in the abstract syntax + -- where we want to keep slot for a type + -- to be added by the type checker...but + -- before typechecking it's just bogus + +placeHolderType :: PostTcType -- Used before typechecking +placeHolderType = panic "Evaluated the place holder for a PostTcType" + +placeHolderKind :: PostTcKind -- Used before typechecking +placeHolderKind = panic "Evaluated the place holder for a PostTcKind" +\end{code} + +%************************************************************************ +%* * \subsection[HsLit]{Literals} %* * %************************************************************************ diff --git a/compiler/hsSyn/HsPat.lhs-boot b/compiler/hsSyn/HsPat.lhs-boot index 7ba338e41f..28991030ad 100644 --- a/compiler/hsSyn/HsPat.lhs-boot +++ b/compiler/hsSyn/HsPat.lhs-boot @@ -1,10 +1,13 @@ \begin{code} +{-# LANGUAGE KindSignatures #-} + module HsPat where import SrcLoc( Located ) import Data.Data -data Pat i +-- IA0_NOTE: We need kind annotation because of kind polymorphism. +data Pat (i :: *) type LPat i = Located (Pat i) instance Typeable1 Pat diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 9e20dbdd4d..fec71af3a0 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -16,11 +16,12 @@ HsTypes: Abstract syntax: user-defined types {-# LANGUAGE DeriveDataTypeable #-} module HsTypes ( - HsType(..), LHsType, + HsType(..), LHsType, HsKind, LHsKind, HsTyVarBndr(..), LHsTyVarBndr, HsTupleSort(..), HsExplicitFlag(..), HsContext, LHsContext, HsQuasiQuote(..), + HsTyWrapper(..), LBangType, BangType, HsBang(..), getBangType, getBangStrictness, @@ -29,16 +30,13 @@ module HsTypes ( mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName, - hsTyVarKind, hsTyVarNameKind, + hsTyVarKind, hsLTyVarKind, hsTyVarNameKind, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe, splitHsForAllTy, splitLHsForAllTy, splitHsClassTy_maybe, splitLHsClassTy_maybe, splitHsFunType, - splitHsAppTys, mkHsAppTys, - - -- Type place holder - PostTcType, placeHolderType, PostTcKind, placeHolderKind, + splitHsAppTys, mkHsAppTys, mkHsOpTy, -- Printing pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, @@ -46,7 +44,9 @@ module HsTypes ( import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) -import NameSet ( FreeVars ) +import HsLit + +import NameSet( FreeVars ) import Type import HsDoc import BasicTypes @@ -61,26 +61,6 @@ import Data.Data %************************************************************************ %* * -\subsection{Annotating the syntax} -%* * -%************************************************************************ - -\begin{code} -type PostTcKind = Kind -type PostTcType = Type -- Used for slots in the abstract syntax - -- where we want to keep slot for a type - -- to be added by the type checker...but - -- before typechecking it's just bogus - -placeHolderType :: PostTcType -- Used before typechecking -placeHolderType = panic "Evaluated the place holder for a PostTcType" - -placeHolderKind :: PostTcKind -- Used before typechecking -placeHolderKind = panic "Evaluated the place holder for a PostTcKind" -\end{code} - -%************************************************************************ -%* * Quasi quotes; used in types and elsewhere %* * %************************************************************************ @@ -136,6 +116,8 @@ type LHsContext name = Located (HsContext name) type HsContext name = [LHsType name] type LHsType name = Located (HsType name) +type HsKind name = HsType name +type LHsKind name = Located (HsKind name) data HsType name = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way @@ -146,7 +128,8 @@ data HsType name (LHsContext name) (LHsType name) - | HsTyVar name -- Type variable or type constructor + | HsTyVar name -- Type variable, type constructor, or data constructor + -- see Note [Promotions (HsTyVar)] | HsAppTy (LHsType name) (LHsType name) @@ -161,7 +144,7 @@ data HsType name | HsTupleTy HsTupleSort [LHsType name] -- Element types (length gives arity) - | HsOpTy (LHsType name) (Located name) (LHsType name) + | HsOpTy (LHsType name) (LHsTyOp name) (LHsType name) | HsParTy (LHsType name) -- See Note [Parens in HsSyn] in HsExpr -- Parenthesis preserved for the precedence re-arrangement in RnTypes @@ -174,7 +157,7 @@ data HsType name (LHsType name) -- Always allowed even without TypeOperators, and has special kinding rule | HsKindSig (LHsType name) -- (ty :: kind) - Kind -- A type with a kind signature + (LHsKind name) -- A type with a kind signature | HsQuasiQuoteTy (HsQuasiQuote name) @@ -189,11 +172,69 @@ data HsType name | HsCoreTy Type -- An escape hatch for tunnelling a *closed* -- Core Type through HsSyn. - + + | HsExplicitListTy -- A promoted explicit list + PostTcKind -- See Note [Promoted lists and tuples] + [LHsType name] + + | HsExplicitTupleTy -- A promoted explicit tuple + [PostTcKind] -- See Note [Promoted lists and tuples] + [LHsType name] + + | HsWrapTy HsTyWrapper (HsType name) -- only in typechecker output + deriving (Data, Typeable) + +data HsTyWrapper + = WpKiApps [Kind] -- kind instantiation: [] k1 k2 .. kn deriving (Data, Typeable) +type LHsTyOp name = HsTyOp (Located name) +type HsTyOp name = (HsTyWrapper, name) + +mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name +mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2 +\end{code} + +Note [Promotions (HsTyVar)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsTyVar: A name in a type or kind. + Here are the allowed namespaces for the name. + In a type: + Var: not allowed + Data: promoted data constructor + Tv: type variable + TcCls before renamer: type constructor, class constructor, or promoted data constructor + TcCls after renamer: type constructor or class constructor + In a kind: + Var, Data: not allowed + Tv: kind variable + TcCls: kind constructor or promoted type constructor + + +Note [Promoted lists and tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice the difference between + HsListTy HsExplicitListTy + HsTupleTy HsExplicitListTupleTy + +E.g. f :: [Int] HsListTy + + g3 :: T '[] All these use + g2 :: T '[True] HsExplicitListTy + g1 :: T '[True,False] + g1a :: T [True,False] (can omit ' where unambiguous) + + kind of T :: [Bool] -> * This kind uses HsListTy! + +E.g. h :: (Int,Bool) HsTupleTy; f is a pair + k :: S '(True,False) HsExplicitTypleTy; S is indexed by + a type-level pair of booleans + kind of S :: (Bool,Bool) -> * This kind uses HsExplicitTupleTy + + +\begin{code} data HsTupleSort = HsUnboxedTuple - | HsBoxyTuple Kind -- Either a Constraint or normal tuple: resolved during type checking + | HsBoxyTuple PostTcKind -- Either a Constraint or normal tuple: resolved during type checking deriving (Data, Typeable) data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable) @@ -252,9 +293,10 @@ data HsTyVarBndr name name -- See Note [Printing KindedTyVars] PostTcKind - | KindedTyVar - name - Kind + | KindedTyVar + name + (LHsKind name) -- The user-supplied kind signature + PostTcKind -- *** NOTA BENE *** A "monotype" in a pragma can have -- for-alls in it, (mostly to do with dictionaries). These -- must be explicitly Kinded. @@ -262,15 +304,18 @@ data HsTyVarBndr name hsTyVarName :: HsTyVarBndr name -> name hsTyVarName (UserTyVar n _) = n -hsTyVarName (KindedTyVar n _) = n +hsTyVarName (KindedTyVar n _ _) = n hsTyVarKind :: HsTyVarBndr name -> Kind hsTyVarKind (UserTyVar _ k) = k -hsTyVarKind (KindedTyVar _ k) = k +hsTyVarKind (KindedTyVar _ _ k) = k + +hsLTyVarKind :: LHsTyVarBndr name -> Kind +hsLTyVarKind = hsTyVarKind . unLoc hsTyVarNameKind :: HsTyVarBndr name -> (name, Kind) hsTyVarNameKind (UserTyVar n k) = (n,k) -hsTyVarNameKind (KindedTyVar n k) = (n,k) +hsTyVarNameKind (KindedTyVar n _ k) = (n,k) hsLTyVarName :: LHsTyVarBndr name -> name hsLTyVarName = hsTyVarName . unLoc @@ -287,12 +332,18 @@ hsLTyVarLocName = fmap hsTyVarName hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name] hsLTyVarLocNames = map hsLTyVarLocName -replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2 -replaceTyVarName (UserTyVar _ k) n' = UserTyVar n' k -replaceTyVarName (KindedTyVar _ k) n' = KindedTyVar n' k - -replaceLTyVarName :: LHsTyVarBndr name1 -> name2 -> LHsTyVarBndr name2 -replaceLTyVarName (L loc n1) n2 = L loc (replaceTyVarName n1 n2) +replaceTyVarName :: (Monad m) => HsTyVarBndr name1 -> name2 -- new type name + -> (LHsKind name1 -> m (LHsKind name2)) -- kind renaming + -> m (HsTyVarBndr name2) +replaceTyVarName (UserTyVar _ k) n' _ = return $ UserTyVar n' k +replaceTyVarName (KindedTyVar _ k tck) n' rn = do + k' <- rn k + return $ KindedTyVar n' k' tck + +replaceLTyVarName :: (Monad m) => LHsTyVarBndr name1 -> name2 + -> (LHsKind name1 -> m (LHsKind name2)) + -> m (LHsTyVarBndr name2) +replaceLTyVarName (L loc n1) n2 rn = replaceTyVarName n1 n2 rn >>= return . L loc \end{code} @@ -351,12 +402,12 @@ splitLHsClassTy_maybe ty = checkl ty [] where checkl (L l ty) args = case ty of - HsTyVar t -> Just (L l t, args) - HsAppTy l r -> checkl l (r:args) - HsOpTy l tc r -> checkl (fmap HsTyVar tc) (l:r:args) - HsParTy t -> checkl t args - HsKindSig ty _ -> checkl ty args - _ -> Nothing + HsTyVar t -> Just (L l t, args) + HsAppTy l r -> checkl l (r:args) + HsOpTy l (_, tc) r -> checkl (fmap HsTyVar tc) (l:r:args) + HsParTy t -> checkl t args + HsKindSig ty _ -> checkl ty args + _ -> Nothing -- Splits HsType into the (init, last) parts -- Breaks up any parens in the result type: @@ -380,9 +431,9 @@ splitHsFunType other = ([], other) instance (OutputableBndr name) => Outputable (HsType name) where ppr ty = pprHsType ty -instance (Outputable name) => Outputable (HsTyVarBndr name) where +instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar name _) = ppr name - ppr (KindedTyVar name kind) = hsep [ppr name, dcolon, pprParendKind kind] + ppr (KindedTyVar name kind _) = parens $ hsep [ppr name, dcolon, ppr kind] pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> SDoc pprHsForAll exp tvs cxt @@ -470,12 +521,28 @@ ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys) where std_con = case con of HsUnboxedTuple -> UnboxedTuple HsBoxyTuple _ -> BoxedTuple -ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind) +ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind) ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s ppr_mono_ty _ (HsCoreTy ty) = ppr ty +ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys) +ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys) + +ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty) + = ppr_mono_ty ctxt_prec ty +-- We are not printing kind applications. If we wanted to do so, we should do +-- something like this: +{- + = go ctxt_prec kis ty + where + go ctxt_prec [] ty = ppr_mono_ty ctxt_prec ty + go ctxt_prec (ki:kis) ty + = maybeParen ctxt_prec pREC_CON $ + hsep [ go pREC_FUN kis ty + , ptext (sLit "@") <> pprParendKind ki ] +-} ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) = maybeParen ctxt_prec pREC_OP $ @@ -485,9 +552,9 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty] -ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) +ppr_mono_ty ctxt_prec (HsOpTy ty1 (wrapper, op) ty2) = maybeParen ctxt_prec pREC_OP $ - ppr_mono_lty pREC_OP ty1 <+> ppr op <+> ppr_mono_lty pREC_OP ty2 + ppr_mono_lty pREC_OP ty1 <+> ppr_mono_ty pREC_CON (HsWrapTy wrapper (HsTyVar (unLoc op))) <+> ppr_mono_lty pREC_OP ty2 ppr_mono_ty _ (HsParTy ty) = parens (ppr_mono_lty pREC_TOP ty) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 394e93d60b..eb6ca87ba3 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1006,11 +1006,31 @@ instance Binary IfaceType where put_ bh ah -- Simple compression for common cases of TyConApp - put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 4; put_ bh k } - put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 5; put_ bh tc; put_ bh tys } - put_ bh (IfaceTyConApp tc tys) = do { putByte bh 6; put_ bh tc; put_ bh tys } - - put_ bh (IfaceCoConApp cc tys) = do { putByte bh 7; put_ bh cc; put_ bh tys } + put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6 + put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7 + put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8 + put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty } + -- Unit tuple and pairs + put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) = putByte bh 10 + put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) + = do { putByte bh 11; put_ bh t1; put_ bh t2 } + -- Kind cases + put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12 + put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13 + put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14 + put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15 + put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16 + put_ bh (IfaceTyConApp IfaceConstraintKindTc []) = putByte bh 17 + put_ bh (IfaceTyConApp IfaceSuperKindTc []) = putByte bh 18 + + put_ bh (IfaceCoConApp cc tys) + = do { putByte bh 19; put_ bh cc; put_ bh tys } + + -- Generic cases + put_ bh (IfaceTyConApp (IfaceTc tc) tys) + = do { putByte bh 20; put_ bh tc; put_ bh tys } + put_ bh (IfaceTyConApp tc tys) + = do { putByte bh 21; put_ bh tc; put_ bh tys } get bh = do h <- getByte bh @@ -1026,20 +1046,70 @@ instance Binary IfaceType where 3 -> do ag <- get bh ah <- get bh return (IfaceFunTy ag ah) - 4 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) } - 5 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) } - 6 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } - _ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) } + + -- Now the special cases for TyConApp + 6 -> return (IfaceTyConApp IfaceIntTc []) + 7 -> return (IfaceTyConApp IfaceCharTc []) + 8 -> return (IfaceTyConApp IfaceBoolTc []) + 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) } + 10 -> return (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) + 11 -> do { t1 <- get bh; t2 <- get bh + ; return (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) } + 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc []) + 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc []) + 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc []) + 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc []) + 16 -> return (IfaceTyConApp IfaceArgTypeKindTc []) + 17 -> return (IfaceTyConApp IfaceConstraintKindTc []) + 18 -> return (IfaceTyConApp IfaceSuperKindTc []) + + 19 -> do { cc <- get bh; tys <- get bh + ; return (IfaceCoConApp cc tys) } + + 20 -> do { tc <- get bh; tys <- get bh + ; return (IfaceTyConApp (IfaceTc tc) tys) } + 21 -> do { tc <- get bh; tys <- get bh + ; return (IfaceTyConApp tc tys) } + + _ -> panic ("get IfaceType " ++ show h) instance Binary IfaceTyCon where - put_ bh (IfaceTc ext) = do { putByte bh 1; put_ bh ext } - put_ bh (IfaceAnyTc k) = do { putByte bh 2; put_ bh k } + -- Int,Char,Bool can't show up here because they can't not be saturated + put_ bh IfaceIntTc = putByte bh 1 + put_ bh IfaceBoolTc = putByte bh 2 + put_ bh IfaceCharTc = putByte bh 3 + put_ bh IfaceListTc = putByte bh 4 + put_ bh IfacePArrTc = putByte bh 5 + put_ bh IfaceLiftedTypeKindTc = putByte bh 6 + put_ bh IfaceOpenTypeKindTc = putByte bh 7 + put_ bh IfaceUnliftedTypeKindTc = putByte bh 8 + put_ bh IfaceUbxTupleKindTc = putByte bh 9 + put_ bh IfaceArgTypeKindTc = putByte bh 10 + put_ bh IfaceConstraintKindTc = putByte bh 11 + put_ bh IfaceSuperKindTc = putByte bh 12 + put_ bh (IfaceTupTc bx ar) = do { putByte bh 13; put_ bh bx; put_ bh ar } + put_ bh (IfaceTc ext) = do { putByte bh 14; put_ bh ext } + put_ bh (IfaceIPTc n) = do { putByte bh 15; put_ bh n } get bh = do h <- getByte bh case h of - 1 -> do { ext <- get bh; return (IfaceTc ext) } - _ -> do { k <- get bh; return (IfaceAnyTc k) } + 1 -> return IfaceIntTc + 2 -> return IfaceBoolTc + 3 -> return IfaceCharTc + 4 -> return IfaceListTc + 5 -> return IfacePArrTc + 6 -> return IfaceLiftedTypeKindTc + 7 -> return IfaceOpenTypeKindTc + 8 -> return IfaceUnliftedTypeKindTc + 9 -> return IfaceUbxTupleKindTc + 10 -> return IfaceArgTypeKindTc + 11 -> return IfaceConstraintKindTc + 12 -> return IfaceSuperKindTc + 13 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } + 14 -> do { ext <- get bh; return (IfaceTc ext) } + 15 -> do { n <- get bh; return (IfaceIPTc n) } + _ -> panic ("get IfaceTyCon " ++ show h) instance Binary IfaceCoCon where put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n } @@ -1061,7 +1131,8 @@ instance Binary IfaceCoCon where 4 -> return IfaceTransCo 5 -> return IfaceInstCo 6 -> do { d <- get bh; return (IfaceNthCo d) } - _ -> do { ip <- get bh; return (IfaceIPCoAx ip) } + 7 -> do { ip <- get bh; return (IfaceIPCoAx ip) } + _ -> panic ("get IfaceCoCon " ++ show h) ------------------------------------------------------------------------- -- IfaceExpr and friends diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 348da8c6c4..9d4a825586 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -15,6 +15,7 @@ module BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, + buildPromotedDataTyCon, TcMethInfo, buildClass, distinctAbstractTyConRhs, totallyAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs, @@ -34,11 +35,13 @@ import MkId import Class import TyCon import Type +import Kind ( promoteType, isPromotableType ) import Coercion import TcRnMonad import Util ( isSingleton ) import Outputable +import Unique ( getUnique ) \end{code} @@ -59,11 +62,10 @@ buildSynTyCon tc_name tvs rhs rhs_kind parent mb_family | otherwise = return (mkSynTyCon tc_name kind tvs rhs parent) - where - kind = mkArrowKinds (map tyVarKind tvs) rhs_kind + where kind = mkForAllArrowKinds tvs rhs_kind ------------------------------------------------------ -buildAlgTyCon :: Name -> [TyVar] +buildAlgTyCon :: Name -> [TyVar] -- ^ Kind variables adn type variables -> ThetaType -- ^ Stupid theta -> AlgTyConRhs -> RecFlag @@ -72,22 +74,21 @@ buildAlgTyCon :: Name -> [TyVar] -> Maybe (TyCon, [Type]) -- ^ family instance if applicable -> TcRnIf m n TyCon -buildAlgTyCon tc_name tvs stupid_theta rhs is_rec gadt_syn +buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn parent mb_family | Just fam_inst_info <- mb_family = -- We need to tie a knot as the coercion of a data instance depends -- on the instance representation tycon and vice versa. ASSERT( isNoParent parent ) fixM $ \ tycon_rec -> do - { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec - ; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs + { fam_parent <- mkFamInstParentInfo tc_name ktvs fam_inst_info tycon_rec + ; return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs fam_parent is_rec gadt_syn) } | otherwise - = return (mkAlgTyCon tc_name kind tvs stupid_theta rhs + = return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs parent is_rec gadt_syn) - where - kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind + where kind = mkForAllArrowKinds ktvs liftedTypeKind -- | If a family tycon with instance types is given, the current tycon is an -- instance of that family and we need to @@ -224,6 +225,11 @@ mkDataConStupidTheta tycon arg_tys univ_tvs arg_tyvars = tyVarsOfTypes arg_tys in_arg_tys pred = not $ isEmptyVarSet $ tyVarsOfType pred `intersectVarSet` arg_tyvars + +buildPromotedDataTyCon :: DataCon -> TyCon +buildPromotedDataTyCon dc = ASSERT ( isPromotableType ty ) + mkPromotedDataTyCon dc (getName dc) (getUnique dc) (promoteType ty) + where ty = dataConUserType dc \end{code} @@ -301,7 +307,7 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec then mkNewTyConRhs tycon_name rec_tycon dict_con else return (mkDataTyConRhs [dict_con]) - ; let { clas_kind = mkArrowKinds (map tyVarKind tvs) constraintKind + ; let { clas_kind = mkForAllArrowKinds tvs constraintKind ; tycon = mkClassTyCon tycon_name clas_kind tvs rhs rec_clas tc_isrec diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index deeac37c65..92fb0d9937 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -500,6 +500,7 @@ pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |")) (map (pprIfaceConDecl tc) cs)) mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType +-- IA0_NOTE: This is wrong, but only used for pretty-printing. mkIfaceEqPred ty1 ty2 = IfaceTyConApp (IfaceTc eqTyConName) [ty1, ty2] pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc @@ -718,7 +719,9 @@ freeNamesIfDecl d@IfaceData{} = freeNamesIfDecl d@IfaceSyn{} = freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfSynRhs (ifSynRhs d) &&& - freeNamesIfTcFam (ifFamInst d) + freeNamesIfTcFam (ifFamInst d) &&& + freeNamesIfKind (ifSynKind d) -- IA0_NOTE: because of promotion, we + -- return names in the kind signature freeNamesIfDecl d@IfaceClass{} = freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfContext (ifCtxt d) &&& @@ -769,6 +772,9 @@ freeNamesIfConDecl c = fnList freeNamesIfType (ifConArgTys c) &&& fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints +freeNamesIfKind :: IfaceType -> NameSet +freeNamesIfKind = freeNamesIfType + freeNamesIfType :: IfaceType -> NameSet freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t @@ -795,8 +801,8 @@ freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty &&& freeNamesIfIdInfo info freeNamesIfTvBndr :: IfaceTvBndr -> NameSet -freeNamesIfTvBndr (_fs,k) = freeNamesIfType k - -- kinds can have Names inside, when the Kind is an equality predicate +freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k + -- kinds can have Names inside, because of promotion freeNamesIfIdBndr :: IfaceIdBndr -> NameSet freeNamesIfIdBndr = freeNamesIfTvBndr diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 471acd0639..5441287eef 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -21,7 +21,7 @@ module IfaceType ( ifaceTyConName, -- Conversion from Type -> IfaceType - toIfaceType, toIfaceContext, + toIfaceType, toIfaceKind, toIfaceContext, toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, toIfaceTyCon, toIfaceTyCon_name, @@ -87,12 +87,20 @@ data IfaceType -- A kind of universal type, used for types, kinds, and coerci type IfacePredType = IfaceType type IfaceContext = [IfacePredType] -data IfaceTyCon -- Encodes type consructors, kind constructors - -- coercion constructors, the lot - = IfaceTc IfExtName -- The common case - | IfaceAnyTc IfaceKind -- Used for AnyTyCon (see Note [Any Types] in TysPrim) - -- other than 'Any :: *' itself - -- XXX: remove this case after Any becomes kind-polymorphic +data IfaceTyCon -- Encodes type constructors, kind constructors + -- coercion constructors, the lot + = IfaceTc IfExtName -- The common case + | IfaceIntTc | IfaceBoolTc | IfaceCharTc + | IfaceListTc | IfacePArrTc + | IfaceTupTc TupleSort Arity + | IfaceIPTc IfIPName -- Used for implicit parameter TyCons + + -- Kind constructors + | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc + | IfaceUbxTupleKindTc | IfaceArgTypeKindTc | IfaceConstraintKindTc + + -- SuperKind constructor + | IfaceSuperKindTc -- IA0_NOTE: You might want to check if I didn't forget something. -- Coercion constructors data IfaceCoCon @@ -103,13 +111,29 @@ data IfaceCoCon | IfaceNthCo Int ifaceTyConName :: IfaceTyCon -> Name +ifaceTyConName IfaceIntTc = intTyConName +ifaceTyConName IfaceBoolTc = boolTyConName +ifaceTyConName IfaceCharTc = charTyConName +ifaceTyConName IfaceListTc = listTyConName +ifaceTyConName IfacePArrTc = parrTyConName +ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar) +ifaceTyConName IfaceLiftedTypeKindTc = liftedTypeKindTyConName +ifaceTyConName IfaceOpenTypeKindTc = openTypeKindTyConName +ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName +ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName +ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName +ifaceTyConName IfaceConstraintKindTc = constraintKindTyConName +ifaceTyConName IfaceSuperKindTc = tySuperKindTyConName ifaceTyConName (IfaceTc ext) = ext -ifaceTyConName (IfaceAnyTc k) = pprPanic "ifaceTyConName:AnyTc" (ppr k) +ifaceTyConName (IfaceIPTc n) = pprPanic "ifaceTyConName:IPTc" (ppr n) -- Note [The Name of an IfaceAnyTc] \end{code} Note [The Name of an IfaceAnyTc] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +IA0_NOTE: This is an old comment. It needs to be updated with IPTc which +I don't know about. + It isn't easy to get the Name of an IfaceAnyTc in a pure way. What you really need to do is to transform it to a TyCon, and get the Name of that. But doing so needs the monad because there's an IfaceKind inside, and we @@ -190,8 +214,7 @@ pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty] pprIfaceTvBndr :: IfaceTvBndr -> SDoc -pprIfaceTvBndr (tv, IfaceTyConApp (IfaceTc n) []) - | n == liftedTypeKindTyConName +pprIfaceTvBndr (tv, IfaceTyConApp IfaceLiftedTypeKindTc []) = ppr tv pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind) pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc @@ -255,18 +278,21 @@ pprIfaceForAllPart tvs ctxt doc ------------------- ppr_tc_app :: Int -> IfaceTyCon -> [IfaceType] -> SDoc -ppr_tc_app _ tc [] = ppr_tc tc -ppr_tc_app _ (IfaceTc n) [ty] | n == listTyConName = brackets (pprIfaceType ty) -ppr_tc_app _ (IfaceTc n) [ty] | n == parrTyConName = pabrackets (pprIfaceType ty) -ppr_tc_app _ (IfaceTc n) tys - | Just (ATyCon tc) <- wiredInNameTyThing_maybe n - , Just sort <- tyConTuple_maybe tc - , tyConArity tc == length tys - = tupleParens sort (sep (punctuate comma (map pprIfaceType tys))) - | Just (ATyCon tc) <- wiredInNameTyThing_maybe n - , Just ip <- tyConIP_maybe tc - , [ty] <- tys - = parens (ppr ip <> dcolon <> pprIfaceType ty) +ppr_tc_app _ tc [] = ppr_tc tc + +ppr_tc_app _ IfaceListTc [ty] = brackets (pprIfaceType ty) +ppr_tc_app _ IfaceListTc _ = panic "ppr_tc_app IfaceListTc" + +ppr_tc_app _ IfacePArrTc [ty] = pabrackets (pprIfaceType ty) +ppr_tc_app _ IfacePArrTc _ = panic "ppr_tc_app IfacePArrTc" + +ppr_tc_app _ (IfaceTupTc sort _) tys = + tupleParens sort (sep (punctuate comma (map pprIfaceType tys))) + +ppr_tc_app _ (IfaceIPTc n) [ty] = + parens (ppr n <> dcolon <> pprIfaceType ty) +ppr_tc_app _ (IfaceIPTc _) _ = panic "ppr_tc_app IfaceIPTc" + ppr_tc_app ctxt_prec tc tys = maybeParen ctxt_prec tYCON_PREC (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))]) @@ -278,11 +304,8 @@ ppr_tc tc = ppr tc ------------------- instance Outputable IfaceTyCon where - ppr (IfaceAnyTc k) = ptext (sLit "Any") <> pprParendIfaceType k - -- We can't easily get the Name of an IfaceAnyTc - -- (see Note [The Name of an IfaceAnyTc]) - -- so we fake it. It's only for debug printing! - ppr (IfaceTc ext) = ppr ext + ppr (IfaceIPTc n) = ppr (IPName n) + ppr other_tc = ppr (ifaceTyConName other_tc) instance Outputable IfaceCoCon where ppr (IfaceCoAx n) = ppr n @@ -350,8 +373,9 @@ toIfaceCoVar = occNameFS . getOccName ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTyCon tc - | isAnyTyCon tc = IfaceAnyTc (toIfaceKind (tyConKind tc)) - | otherwise = IfaceTc (tyConName tc) + | isTupleTyCon tc = IfaceTupTc (tupleTyConSort tc) (tyConArity tc) + | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n) + | otherwise = toIfaceTyCon_name (tyConName tc) toIfaceTyCon_name :: Name -> IfaceTyCon toIfaceTyCon_name nm @@ -362,7 +386,20 @@ toIfaceTyCon_name nm toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon toIfaceWiredInTyCon tc nm - | isAnyTyCon tc = IfaceAnyTc (toIfaceKind (tyConKind tc)) + | isTupleTyCon tc = IfaceTupTc (tupleTyConSort tc) (tyConArity tc) + | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n) + | nm == intTyConName = IfaceIntTc + | nm == boolTyConName = IfaceBoolTc + | nm == charTyConName = IfaceCharTc + | nm == listTyConName = IfaceListTc + | nm == parrTyConName = IfacePArrTc + | nm == liftedTypeKindTyConName = IfaceLiftedTypeKindTc + | nm == unliftedTypeKindTyConName = IfaceUnliftedTypeKindTc + | nm == openTypeKindTyConName = IfaceOpenTypeKindTc + | nm == argTypeKindTyConName = IfaceArgTypeKindTc + | nm == constraintKindTyConName = IfaceConstraintKindTc + | nm == ubxTupleKindTyConName = IfaceUbxTupleKindTc + | nm == tySuperKindTyConName = IfaceSuperKindTc | otherwise = IfaceTc nm ---------------- diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index f047f588f4..86c46bac6c 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1490,7 +1490,7 @@ classToIfaceDecl clas = IfaceAT (tyThingToIfaceDecl (ATyCon tc)) (map to_if_at_def defs) where - to_if_at_def (ATD tvs pat_tys ty) + to_if_at_def (ATD tvs pat_tys ty _loc) = IfaceATD (toIfaceTvBndrs tvs) (map toIfaceType pat_tys) (toIfaceType ty) toIfaceClassOp (sel_id, def_meth) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index a11051b65f..125b885256 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -41,7 +41,7 @@ import TyCon import DataCon import PrelNames import TysWiredIn -import TysPrim ( anyTyConOfKind ) +import TysPrim ( tySuperKindTyCon ) import BasicTypes ( Arity, strongLoopBreaker ) import Literal import qualified Var @@ -502,7 +502,9 @@ tc_iface_decl _parent ignore_prags return tc tc_iface_at_def (IfaceATD tvs pat_tys ty) = - bindIfaceTyVars_AT tvs $ \tvs' -> liftM2 (ATD tvs') (mapM tcIfaceType pat_tys) (tcIfaceType ty) + bindIfaceTyVars_AT tvs $ + \tvs' -> liftM2 (\pats tys -> ATD tvs' pats tys noSrcSpan) + (mapM tcIfaceType pat_tys) (tcIfaceType ty) mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty] @@ -1235,9 +1237,15 @@ tcIfaceGlobal name -- emasculated form (e.g. lacking data constructors). tcIfaceTyCon :: IfaceTyCon -> IfL TyCon -tcIfaceTyCon (IfaceAnyTc kind) = do { tc_kind <- tcIfaceType kind - ; tcWiredInTyCon (anyTyConOfKind tc_kind) } -tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name +tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon +tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon +tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon +tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon +tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon +tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar) +tcIfaceTyCon (IfaceIPTc n) = do { n' <- newIPName n + ; tcWiredInTyCon (ipTyCon n') } +tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name ; return (check_tc (tyThingTyCon thing)) } where check_tc tc @@ -1245,6 +1253,14 @@ tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name IfaceTc _ -> tc _ -> pprTrace "check_tc" (ppr tc) tc | otherwise = tc +-- we should be okay just returning Kind constructors without extra loading +tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon +tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon +tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon +tcIfaceTyCon IfaceArgTypeKindTc = return argTypeKindTyCon +tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon +tcIfaceTyCon IfaceConstraintKindTc = return constraintKindTyCon +tcIfaceTyCon IfaceSuperKindTc = return tySuperKindTyCon -- Even though we are in an interface file, we want to make -- sure the instances and RULES of this tycon are loaded @@ -1310,12 +1326,22 @@ bindIfaceTyVar (occ,kind) thing_inside bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a bindIfaceTyVars bndrs thing_inside - = do { names <- newIfaceNames (map mkTyVarOccFS occs) - ; tyvars <- zipWithM mk_iface_tyvar names kinds - ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) } + = do { names <- newIfaceNames (map mkTyVarOccFS occs) + ; let (kis_kind, tys_kind) = span isSuperIfaceKind kinds + (kis_name, tys_name) = splitAt (length kis_kind) names + -- We need to bring the kind variables in scope since type + -- variables may mention them. + ; kvs <- zipWithM mk_iface_tyvar kis_name kis_kind + ; extendIfaceTyVarEnv kvs $ do + { tvs <- zipWithM mk_iface_tyvar tys_name tys_kind + ; extendIfaceTyVarEnv tvs (thing_inside (kvs ++ tvs)) } } where (occs,kinds) = unzip bndrs +isSuperIfaceKind :: IfaceKind -> Bool +isSuperIfaceKind (IfaceTyConApp IfaceSuperKindTc []) = True +isSuperIfaceKind _ = False + mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar mk_iface_tyvar name ifKind = do { kind <- tcIfaceType ifKind @@ -1328,12 +1354,14 @@ bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a -- Here 'a' is in scope when we look at the 'data T' bindIfaceTyVars_AT [] thing_inside = thing_inside [] -bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside - = bindIfaceTyVars_AT bs $ \ bs' -> - do { mb_tv <- lookupIfaceTyVar tv_occ - ; case mb_tv of - Just b' -> thing_inside (b':bs') - Nothing -> bindIfaceTyVar b $ \ b' -> - thing_inside (b':bs') } -\end{code} +bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside + = do { mb_tv <- lookupIfaceTyVar tv_occ + ; let bind_b :: (TyVar -> IfL a) -> IfL a + bind_b = case mb_tv of + Just b' -> \k -> k b' + Nothing -> bindIfaceTyVar b + ; bind_b $ \b' -> + bindIfaceTyVars_AT bs $ \bs' -> + thing_inside (b':bs') } +\end{code} diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 19bce9f82f..2c0cccb0ba 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -393,7 +393,8 @@ data ExtensionFlag | Opt_DoAndIfThenElse | Opt_RebindableSyntax | Opt_ConstraintKinds - + | Opt_PolyKinds -- Kind polymorphism + | Opt_StandaloneDeriving | Opt_DeriveDataTypeable | Opt_DeriveFunctor @@ -1904,7 +1905,8 @@ xFlags = [ ( "DoAndIfThenElse", Opt_DoAndIfThenElse, nop ), ( "RebindableSyntax", Opt_RebindableSyntax, nop ), ( "ConstraintKinds", Opt_ConstraintKinds, nop ), - ( "MonoPatBinds", Opt_MonoPatBinds, + ( "PolyKinds", Opt_PolyKinds, nop ), + ( "MonoPatBinds", Opt_MonoPatBinds, \ turn_on -> when turn_on $ deprecate "Experimental feature now removed; has no effect" ), ( "ExplicitForAll", Opt_ExplicitForAll, nop ), ( "AlternativeLayoutRule", Opt_AlternativeLayoutRule, nop ), @@ -1988,7 +1990,9 @@ impliedFlags , (Opt_TypeFamilies, turnOn, Opt_MonoLocalBinds) , (Opt_TypeFamilies, turnOn, Opt_KindSignatures) -- Type families use kind signatures - -- all over the place + -- all over the place + + , (Opt_PolyKinds, turnOn, Opt_KindSignatures) , (Opt_ImpredicativeTypes, turnOn, Opt_RankNTypes) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 039e8f15ba..d60e6d7f59 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -264,7 +264,7 @@ import RdrName import qualified HsSyn -- hack as we want to reexport the whole module import HsSyn hiding ((<.>)) import Type hiding( typeKind ) -import Coercion ( synTyConResKind ) +import Kind ( synTyConResKind ) import TcType hiding( typeKind ) import Id import TysPrim ( alphaTyVars ) @@ -881,7 +881,7 @@ compileCore simplify fn = do gutsToCoreModule (Right mg) = CoreModule { cm_module = mg_module mg, cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) - (mg_tcs mg) (mg_clss mg) + (mg_tcs mg) (mg_fam_insts mg), cm_binds = mg_binds mg } diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 753f044b71..ca524aa24b 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -83,7 +83,6 @@ import DsMeta ( templateHaskellNames ) import VarSet import VarEnv ( emptyTidyEnv ) import Panic -import Class import Data.List #endif @@ -1384,8 +1383,7 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do hsc_env <- getHscEnv liftIO $ linkDecls hsc_env src_span cbc - let tcs = filter (not . isImplicitTyCon) $ mg_tcs simpl_mg - clss = mg_clss simpl_mg + let tcs = filter (not . isImplicitTyCon) $ (mg_tcs simpl_mg) ext_vars = filter (isExternalName . idName) $ bindersOfBinds core_binds @@ -1400,7 +1398,6 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do tythings = map AnId user_vars ++ map ATyCon tcs - ++ map (ATyCon . classTyCon) clss let ictxt1 = extendInteractiveContext icontext tythings ictxt = ictxt1 { ic_sys_vars = sys_vars ++ ic_sys_vars ictxt1, @@ -1506,7 +1503,6 @@ mkModGuts mod binds = mg_rdr_env = emptyGlobalRdrEnv, mg_fix_env = emptyFixityEnv, mg_tcs = [], - mg_clss = [], mg_insts = [], mg_fam_insts = [], mg_rules = [], diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index c2cf2793b4..3391f6a5ed 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -813,7 +813,7 @@ data ModGuts mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module -- ToDo: I'm unconvinced this is actually used anywhere mg_tcs :: ![TyCon], -- ^ TyCons declared in this module - mg_clss :: ![Class], -- ^ Classes declared in this module + -- (includes TyCons for classes) mg_insts :: ![Instance], -- ^ Class instances declared in this module mg_fam_insts :: ![FamInst], -- ^ Family instances declared in this module mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains @@ -1317,14 +1317,14 @@ mkTypeEnvWithImplicits things = `plusNameEnv` mkTypeEnv (concatMap implicitTyThings things) -typeEnvFromEntities :: [Id] -> [TyCon] -> [Class] -> [FamInst] -> TypeEnv -typeEnvFromEntities ids tcs clss faminsts = +typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv +typeEnvFromEntities ids tcs faminsts = mkTypeEnv ( map AnId ids ++ map ATyCon all_tcs ++ concatMap implicitTyConThings all_tcs ) where - all_tcs = tcs ++ map classTyCon clss ++ map famInstTyCon faminsts + all_tcs = tcs ++ map famInstTyCon faminsts lookupTypeEnv = lookupNameEnv diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index b2a6b5bb67..ef17f3120a 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -129,7 +129,6 @@ mkBootModDetailsTc hsc_env TcGblEnv{ tcg_exports = exports, tcg_type_env = type_env, -- just for the Ids tcg_tcs = tcs, - tcg_clss = clss, tcg_insts = insts, tcg_fam_insts = fam_insts } @@ -139,7 +138,7 @@ mkBootModDetailsTc hsc_env ; let { insts' = tidyInstances globaliseAndTidyId insts ; dfun_ids = map instanceDFunId insts' ; type_env1 = mkBootTypeEnv (availsToNameSet exports) - (typeEnvIds type_env) tcs clss fam_insts + (typeEnvIds type_env) tcs fam_insts ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids } ; return (ModDetails { md_types = type_env' @@ -153,10 +152,10 @@ mkBootModDetailsTc hsc_env } where -mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [Class] -> [FamInst] -> TypeEnv -mkBootTypeEnv exports ids tcs clss fam_insts +mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv +mkBootTypeEnv exports ids tcs fam_insts = tidyTypeEnv True False exports $ - typeEnvFromEntities final_ids tcs clss fam_insts + typeEnvFromEntities final_ids tcs fam_insts where -- Find the LocalIds in the type env that are exported -- Make them into GlobalIds, and tidy their types @@ -294,7 +293,6 @@ tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) tidyProgram hsc_env (ModGuts { mg_module = mod , mg_exports = exports , mg_tcs = tcs - , mg_clss = clss , mg_insts = insts , mg_fam_insts = fam_insts , mg_binds = binds @@ -314,7 +312,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod } ; showPass dflags CoreTidy - ; let { type_env = typeEnvFromEntities [] tcs clss fam_insts + ; let { type_env = typeEnvFromEntities [] tcs fam_insts ; implicit_binds = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++ diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index c036d74d8d..b32dd8a675 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -524,6 +524,7 @@ data Token | ITcomma | ITunderscore | ITbackquote + | ITsimpleQuote -- ' | ITvarid FastString -- identifiers | ITconid FastString @@ -558,7 +559,6 @@ data Token | ITcloseQuote -- |] | ITidEscape FastString -- $x | ITparenEscape -- $( - | ITvarQuote -- ' | ITtyQuote -- '' | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|] @@ -1229,7 +1229,7 @@ lex_stringgap s = do lex_char_tok :: Action -- Here we are basically parsing character literals, such as 'x' or '\n' -- but, when Template Haskell is on, we additionally spot --- 'x and ''T, returning ITvarQuote and ITtyQuote respectively, +-- 'x and ''T, returning ITsimpleQuote and ITtyQuote respectively, -- but WITHOUT CONSUMING the x or T part (the parser does that). -- So we have to do two characters of lookahead: when we see 'x we need to -- see if there's a trailing quote @@ -1240,11 +1240,8 @@ lex_char_tok span _buf _len = do -- We've seen ' Nothing -> lit_error i1 Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' - th_exts <- extension thEnabled - if th_exts then do - setInput i2 - return (L (mkRealSrcSpan loc end2) ITtyQuote) - else lit_error i1 + setInput i2 + return (L (mkRealSrcSpan loc end2) ITtyQuote) Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash setInput i2 @@ -1267,10 +1264,8 @@ lex_char_tok span _buf _len = do -- We've seen ' _other -> do -- We've seen 'x not followed by quote -- (including the possibility of EOF) -- If TH is on, just parse the quote only - th_exts <- extension thEnabled let (AI end _) = i1 - if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote) - else lit_error i2 + return (L (mkRealSrcSpan loc end) ITsimpleQuote) finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token) finish_char_tok loc ch -- We've already seen the closing quote diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index b1c0bbbbe6..b390009fbf 100644..100755 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -32,7 +32,7 @@ import RdrHsSyn import HscTypes ( IsBootInterface, WarningTxt(..) ) import Lexer import RdrName -import TysPrim ( eqPrimTyCon ) +import TysPrim ( liftedTypeKindTyConName, eqPrimTyCon ) import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, unboxedSingletonTyCon, unboxedSingletonDataCon, listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) @@ -45,8 +45,7 @@ import DataCon ( DataCon, dataConName ) import SrcLoc import Module import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) -import Type ( Kind, liftedTypeKind, unliftedTypeKind ) -import Coercion ( mkArrowKind ) +import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind ) import Class ( FunDep ) import BasicTypes import DynFlags @@ -310,6 +309,7 @@ incorrect. ';' { L _ ITsemi } ',' { L _ ITcomma } '`' { L _ ITbackquote } + SIMPLEQUOTE { L _ ITsimpleQuote } -- 'x VARID { L _ (ITvarid _) } -- identifiers CONID { L _ (ITconid _) } @@ -349,7 +349,6 @@ incorrect. '|]' { L _ ITcloseQuote } TH_ID_SPLICE { L _ (ITidEscape _) } -- $x '$(' { L _ ITparenEscape } -- $( exp ) -TH_VAR_QUOTE { L _ ITvarQuote } -- 'x TH_TY_QUOTE { L _ ITtyQuote } -- ''T TH_QUASIQUOTE { L _ (ITquasiQuote _) } @@ -718,9 +717,9 @@ data_or_newtype :: { Located NewOrData } : 'data' { L1 DataType } | 'newtype' { L1 NewType } -opt_kind_sig :: { Located (Maybe Kind) } +opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) } : { noLoc Nothing } - | '::' kind { LL (Just (unLoc $2)) } + | '::' kind { LL (Just $2) } -- tycl_hdr parses the header of a class or data type decl, -- which takes the form @@ -968,8 +967,8 @@ sigtypes1 :: { [LHsType RdrName] } -- Always HsForAllTys -- Types infixtype :: { LHsType RdrName } - : btype qtyconop type { LL $ HsOpTy $1 $2 $3 } - | btype tyvarop type { LL $ HsOpTy $1 $2 $3 } + : btype qtyconop type { LL $ mkHsOpTy $1 $2 $3 } + | btype tyvarop type { LL $ mkHsOpTy $1 $2 $3 } strict_mark :: { Located HsBang } : '!' { L1 HsStrict } @@ -1020,18 +1019,21 @@ context :: { LHsContext RdrName } type :: { LHsType RdrName } : btype { $1 } - | btype qtyconop type { LL $ HsOpTy $1 $2 $3 } - | btype tyvarop type { LL $ HsOpTy $1 $2 $3 } + | btype qtyconop type { LL $ mkHsOpTy $1 $2 $3 } + | btype tyvarop type { LL $ mkHsOpTy $1 $2 $3 } | btype '->' ctype { LL $ HsFunTy $1 $3 } | btype '~' btype { LL $ HsEqTy $1 $3 } + -- see Note [Promotion] + | btype SIMPLEQUOTE qconop type { LL $ mkHsOpTy $1 $3 $4 } + | btype SIMPLEQUOTE varop type { LL $ mkHsOpTy $1 $3 $4 } typedoc :: { LHsType RdrName } : btype { $1 } | btype docprev { LL $ HsDocTy $1 $2 } - | btype qtyconop type { LL $ HsOpTy $1 $2 $3 } - | btype qtyconop type docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 } - | btype tyvarop type { LL $ HsOpTy $1 $2 $3 } - | btype tyvarop type docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 } + | btype qtyconop type { LL $ mkHsOpTy $1 $2 $3 } + | btype qtyconop type docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 } + | btype tyvarop type { LL $ mkHsOpTy $1 $2 $3 } + | btype tyvarop type docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 } | btype '->' ctypedoc { LL $ HsFunTy $1 $3 } | btype docprev '->' ctypedoc { LL $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 } | btype '~' btype { LL $ HsEqTy $1 $3 } @@ -1050,11 +1052,17 @@ atype :: { LHsType RdrName } | '[' ctype ']' { LL $ HsListTy $2 } | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } - | '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) } + | '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 } | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) } | '$(' exp ')' { LL $ mkHsSpliceTy $2 } - | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ + | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ mkUnqual varName (getTH_ID_SPLICE $1) } + -- see Note [Promotion] for the followings + | SIMPLEQUOTE qconid { LL $ HsTyVar $ unLoc $2 } + | SIMPLEQUOTE '(' ')' { LL $ HsTyVar $ getRdrName unitDataCon } + | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' { LL $ HsExplicitTupleTy [] ($3 : $5) } + | SIMPLEQUOTE '[' comma_types0 ']' { LL $ HsExplicitListTy placeHolderKind $3 } + | '[' ctype ',' comma_types1 ']' { LL $ HsExplicitListTy placeHolderKind ($2 : $4) } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b @@ -1081,8 +1089,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } tv_bndr :: { LHsTyVarBndr RdrName } : tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) } - | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) - (unLoc $4)) } + | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4 placeHolderKind) } fds :: { Located [Located (FunDep RdrName)] } : {- empty -} { noLoc [] } @@ -1103,15 +1110,55 @@ varids0 :: { Located [RdrName] } ----------------------------------------------------------------------------- -- Kinds -kind :: { Located Kind } - : akind { $1 } - | akind '->' kind { LL (mkArrowKind (unLoc $1) (unLoc $3)) } +kind :: { LHsKind RdrName } + : bkind { $1 } + | bkind '->' kind { LL $ HsFunTy $1 $3 } + +bkind :: { LHsKind RdrName } + : akind { $1 } + | bkind akind { LL $ HsAppTy $1 $2 } + +akind :: { LHsKind RdrName } + : '*' { L1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) } + | '(' kind ')' { LL $ HsParTy $2 } + | pkind { $1 } + +pkind :: { LHsKind RdrName } -- promoted type, see Note [Promotion] + : qtycon { L1 $ HsTyVar $ unLoc $1 } + | '(' ')' { LL $ HsTyVar $ getRdrName unitTyCon } + | '(' kind ',' comma_kinds1 ')' { LL $ HsTupleTy (HsBoxyTuple placeHolderKind) ($2 : $4) } + | '[' kind ']' { LL $ HsListTy $2 } + +comma_kinds1 :: { [LHsKind RdrName] } + : kind { [$1] } + | kind ',' comma_kinds1 { $1 : $3 } + +{- Note [Promotion] + ~~~~~~~~~~~~~~~~ + +- Syntax of promoted qualified names +We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified +names. Moreover ticks are only allowed in types, not in kinds, for a +few reasons: + 1. we don't need quotes since we cannot define names in kinds + 2. if one day we merge types and kinds, tick would mean look in DataName + 3. we don't have a kind namespace anyway + +- Syntax of explicit kind polymorphism (IA0_TODO: not yet implemented) +Kind abstraction is implicit. We write +> data SList (s :: k -> *) (as :: [k]) where ... +because it looks like what we do in terms +> id (x :: a) = x + +- Name resolution +When the user write Zero instead of 'Zero in types, we parse it a +HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We +deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not +bounded in the type level, then we look for it in the term level (we +change its namespace to DataName, see Note [Demotion] in OccName). And +both become a HsTyVar ("Zero", DataName) after the renamer. -akind :: { Located Kind } - : '*' { L1 liftedTypeKind } - | '!' { L1 unliftedTypeKind } - | CONID {% checkKindName (L1 (getCONID $1)) } - | '(' kind ')' { LL (unLoc $2) } +-} ----------------------------------------------------------------------------- @@ -1411,10 +1458,10 @@ aexp2 :: { LHsExpr RdrName } | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } - | TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) } - | TH_VAR_QUOTE qcon { LL $ HsBracket (VarBr (unLoc $2)) } - | TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr (unLoc $2)) } - | TH_TY_QUOTE gtycon { LL $ HsBracket (VarBr (unLoc $2)) } + | SIMPLEQUOTE qvar { LL $ HsBracket (VarBr True (unLoc $2)) } + | SIMPLEQUOTE qcon { LL $ HsBracket (VarBr True (unLoc $2)) } + | TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr False (unLoc $2)) } + | TH_TY_QUOTE gtycon { LL $ HsBracket (VarBr False (unLoc $2)) } | '[|' exp '|]' { LL $ HsBracket (ExpBr $2) } | '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) } | '[p|' infixexp '|]' {% checkPattern $2 >>= \p -> diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 99efa7a4ae..3a786ea04b 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -20,7 +20,7 @@ import Type ( Kind, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, mkTyConApp ) -import Coercion( mkArrowKind ) +import Kind( mkArrowKind ) import Name( Name, nameOccName, nameModule, mkExternalName, wiredInNameTyThing_maybe ) import Module import ParserCoreUtils @@ -346,7 +346,7 @@ eqTc (IfaceTc name) tycon = name == tyConName tycon -- Tiresomely, we have to generate both HsTypes (in type/class decls) -- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes, -- and convert to HsTypes here. But the IfaceTypes we can see here --- are very limited (see the productions for 'ty', so the translation +-- are very limited (see the productions for 'ty'), so the translation -- isn't hard toHsType :: IfaceType -> LHsType RdrName toHsType (IfaceTyVar v) = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOccFS v)) @@ -355,12 +355,12 @@ toHsType (IfaceFunTy t1 t2) = noLoc $ HsFunTy (toHsType t1) (toHsType t2) toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t) --- We also need to convert IfaceKinds to Kinds (now that they are different). -- Only a limited form of kind will be encountered... hopefully -toKind :: IfaceKind -> Kind -toKind (IfaceFunTy ifK1 ifK2) = mkArrowKind (toKind ifK1) (toKind ifK2) -toKind (IfaceTyConApp ifKc []) = mkTyConApp (toKindTc ifKc) [] -toKind other = pprPanic "toKind" (ppr other) +toHsKind :: IfaceKind -> LHsKind RdrName +-- IA0_NOTE: Shouldn't we add kind variables? +toHsKind (IfaceFunTy ifK1 ifK2) = noLoc $ HsFunTy (toHsKind ifK1) (toHsKind ifK2) +toHsKind (IfaceTyConApp ifKc []) = noLoc $ HsTyVar (nameRdrName (tyConName (toKindTc ifKc))) +toHsKind other = pprPanic "toHsKind" (ppr other) toKindTc :: IfaceTyCon -> TyCon toKindTc (IfaceTc n) | Just (ATyCon tc) <- wiredInNameTyThing_maybe n = tc @@ -375,7 +375,7 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName) ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName -toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toKind k) +toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toHsKind k) placeHolderKind ifaceExtRdrName :: Name -> RdrName ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name) diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 20055e3b7d..8ab71f3885 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -42,7 +42,6 @@ module RdrHsSyn ( checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkDoAndIfThenElse, - checkKindName, checkRecordSyntax, parseError, parseErrorSDoc, @@ -50,16 +49,13 @@ module RdrHsSyn ( import HsSyn -- Lots of it import Class ( FunDep ) -import TypeRep ( Kind ) -import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, +import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) -import OccName ( occNameFS ) -import Name ( Name, nameOccName ) +import Name ( Name ) import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, InlinePragma(..), InlineSpec(..) ) import Lexer import TysWiredIn ( unitTyCon ) -import TysPrim ( constraintKindTyConName, constraintKind ) import ForeignCall import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameString ) @@ -110,6 +106,8 @@ extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt) extract_ltys :: [LHsType RdrName] -> [Located RdrName] -> [Located RdrName] extract_ltys tys acc = foldr extract_lty acc tys +-- IA0_NOTE: Should this function also return kind variables? +-- (explicit kind poly) extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName] extract_lty (L loc ty) acc = case ty of @@ -123,7 +121,7 @@ extract_lty (L loc ty) acc HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) HsIParamTy _ ty -> extract_lty ty acc HsEqTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) - HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc)) + HsOpTy ty1 (_, (L loc tv)) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc)) HsParTy ty -> extract_lty ty acc HsCoreTy {} -> acc -- The type is closed HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables @@ -135,6 +133,9 @@ extract_lty (L loc ty) acc where locals = hsLTyVarNames tvs HsDocTy ty _ -> extract_lty ty acc + HsExplicitListTy _ tys -> extract_ltys tys acc + HsExplicitTupleTy _ tys -> extract_ltys tys acc + HsWrapTy _ _ -> panic "extract_lty" extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName] extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc @@ -191,7 +192,7 @@ mkTyData :: SrcSpan -> NewOrData -> Bool -- True <=> data family instance -> Located (Maybe (LHsContext RdrName), LHsType RdrName) - -> Maybe Kind + -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] -> Maybe [LHsType RdrName] -> P (LTyClDecl RdrName) @@ -219,7 +220,7 @@ mkTySynonym loc is_family lhs rhs mkTyFamily :: SrcSpan -> FamilyFlavour -> LHsType RdrName -- LHS - -> Maybe Kind -- Optional kind signature + -> Maybe (LHsKind RdrName) -- Optional kind signature -> P (LTyClDecl RdrName) mkTyFamily loc flavour lhs ksig = do { (tc, tparams) <- checkTyClHdr lhs @@ -493,7 +494,7 @@ checkTyVars tycl_hdr tparms = mapM chk tparms where -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return (L l (KindedTyVar tv k)) + | isRdrTyVar tv = return (L l (KindedTyVar tv k placeHolderKind)) chk (L l (HsTyVar tv)) | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind)) chk t@(L l _) @@ -532,10 +533,10 @@ checkTyClHdr ty where goL (L l ty) acc = go l ty acc - go l (HsTyVar tc) acc + go l (HsTyVar tc) acc | isRdrTc tc = return (L l tc, acc) - - go _ (HsOpTy t1 ltc@(L _ tc) t2) acc + + go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc | isRdrTc tc = return (ltc, t1:t2:acc) go _ (HsParTy ty) acc = goL ty acc go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc) @@ -776,17 +777,6 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+> text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+> text "else" <+> ppr elseExpr - -checkKindName :: Located FastString -> P (Located Kind) -checkKindName (L l fs) = do - pState <- getPState - let ext_enabled = xopt Opt_ConstraintKinds (dflags pState) - is_kosher = fs == occNameFS (nameOccName constraintKindTyConName) - if not ext_enabled || not is_kosher - then parseErrorSDoc l (text "Unexpected named kind:" - $$ nest 4 (ppr fs) - $$ if (not ext_enabled && is_kosher) then text "Perhaps you meant to use -XConstraintKinds?" else empty) - else return (L l constraintKind) \end{code} diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index ea44353626..cd6a621868 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -1241,11 +1241,13 @@ eitherTyConKey = mkPreludeTyConUnique 84 -- Super Kinds constructors tySuperKindTyConKey :: Unique -tySuperKindTyConKey = mkPreludeTyConUnique 85 +tySuperKindTyConKey = mkPreludeTyConUnique 85 -- Kind constructors -liftedTypeKindTyConKey, openTypeKindTyConKey, unliftedTypeKindTyConKey, - ubxTupleKindTyConKey, argTypeKindTyConKey, constraintKindTyConKey :: Unique +liftedTypeKindTyConKey, anyKindTyConKey, openTypeKindTyConKey, + unliftedTypeKindTyConKey, ubxTupleKindTyConKey, argTypeKindTyConKey, + constraintKindTyConKey :: Unique +anyKindTyConKey = mkPreludeTyConUnique 86 liftedTypeKindTyConKey = mkPreludeTyConUnique 87 openTypeKindTyConKey = mkPreludeTyConUnique 88 unliftedTypeKindTyConKey = mkPreludeTyConUnique 89 @@ -1591,6 +1593,24 @@ mzipIdKey = mkPreludeMiscIdUnique 197 %************************************************************************ %* * +\subsection{Standard groups of types} +%* * +%************************************************************************ + +\begin{code} +kindKeys :: [Unique] +kindKeys = [ anyKindTyConKey + , liftedTypeKindTyConKey + , openTypeKindTyConKey + , unliftedTypeKindTyConKey + , ubxTupleKindTyConKey + , argTypeKindTyConKey + , constraintKindTyConKey ] +\end{code} + + +%************************************************************************ +%* * \subsection[Class-std-groups]{Standard groups of Prelude classes} %* * %************************************************************************ diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 0c2de06924..e97f462dcc 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -21,20 +21,21 @@ module TysPrim( tyVarList, alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTy, betaTy, gammaTy, deltaTy, openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars, - argAlphaTyVars, argAlphaTyVar, argAlphaTy, argBetaTy, argBetaTyVar, + argAlphaTy, argAlphaTyVar, argAlphaTyVars, argBetaTy, argBetaTyVar, + kKiVar, -- Kind constructors... - tySuperKindTyCon, tySuperKind, + tySuperKindTyCon, tySuperKind, anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon, - tySuperKindTyConName, liftedTypeKindTyConName, + tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName, openTypeKindTyConName, unliftedTypeKindTyConName, ubxTupleKindTyConName, argTypeKindTyConName, constraintKindTyConName, -- Kinds - liftedTypeKind, unliftedTypeKind, openTypeKind, + anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind, mkArrowKind, mkArrowKinds, @@ -74,21 +75,20 @@ module TysPrim( eqPrimTyCon, -- ty1 ~# ty2 -- * Any - anyTy, anyTyCon, anyTyConOfKind, anyTypeOfKind + anyTy, anyTyCon, anyTypeOfKind ) where #include "HsVersions.h" -import Var ( TyVar, mkTyVar ) +import Var ( TyVar, KindVar, mkTyVar ) import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName ) -import OccName ( mkTcOcc,mkTyVarOccFS, mkTcOccFS ) +import OccName ( mkTyVarOccFS, mkTcOccFS ) import TyCon import TypeRep import SrcLoc import Unique ( mkAlphaTyVarUnique ) import PrelNames import FastString -import Outputable import Data.Char \end{code} @@ -127,6 +127,7 @@ primTyCons , word32PrimTyCon , word64PrimTyCon , anyTyCon + , anyKindTyCon , eqPrimTyCon , liftedTypeKindTyCon @@ -223,6 +224,10 @@ argAlphaTyVars@(argAlphaTyVar : argBetaTyVar : _) = tyVarList argTypeKind argAlphaTy, argBetaTy :: Type argAlphaTy = mkTyVarTy argAlphaTyVar argBetaTy = mkTyVarTy argBetaTyVar + +kKiVar :: KindVar +kKiVar = (tyVarList tySuperKind) !! 10 + \end{code} @@ -237,15 +242,20 @@ funTyConName :: Name funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon funTyCon :: TyCon -funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) - -- You might think that (->) should have type (?? -> ? -> *), and you'd be right - -- But if we do that we get kind errors when saying - -- instance Control.Arrow (->) - -- becuase the expected kind is (*->*->*). The trouble is that the - -- expected/actual stuff in the unifier does not go contra-variant, whereas - -- the kind sub-typing does. Sigh. It really only matters if you use (->) in - -- a prefix way, thus: (->) Int# Int#. And this is unusual. - -- because they are never in scope in the source +funTyCon = mkFunTyCon funTyConName (mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind) +-- One step to remove subkinding. +-- (->) :: * -> * -> * +-- but we should have (and want) the following typing rule for fully applied arrows +-- Gamma |- tau :: k1 k1 in {*, #} +-- Gamma |- sigma :: k2 k2 in {*, #, (#)} +-- ----------------------------------------- +-- Gamma |- tau -> sigma :: * +-- Currently we have the following rule which achieves more or less the same effect +-- Gamma |- tau :: ?? +-- Gamma |- sigma :: ? +-- -------------------------- +-- Gamma |- tau -> sigma :: * +-- In the end we don't want subkinding at all. \end{code} @@ -257,18 +267,19 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] lif \begin{code} -- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's -tySuperKindTyCon, liftedTypeKindTyCon, +tySuperKindTyCon, anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, ubxTupleKindTyCon, argTypeKindTyCon, constraintKindTyCon :: TyCon -tySuperKindTyConName, liftedTypeKindTyConName, +tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName, openTypeKindTyConName, unliftedTypeKindTyConName, ubxTupleKindTyConName, argTypeKindTyConName, constraintKindTyConName :: Name tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName +anyKindTyCon = mkKindTyCon anyKindTyConName tySuperKind liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind @@ -280,6 +291,7 @@ constraintKindTyCon = mkKindTyCon constraintKindTyConName tySuperKind -- ... and now their names tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon +anyKindTyConName = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKindTyCon liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon openTypeKindTyConName = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon @@ -302,13 +314,15 @@ kindTyConType :: TyCon -> Type kindTyConType kind = TyConApp kind [] -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind :: Kind +anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind :: Kind +-- See Note [Any kinds] +anyKind = kindTyConType anyKindTyCon liftedTypeKind = kindTyConType liftedTypeKindTyCon unliftedTypeKind = kindTyConType unliftedTypeKindTyCon openTypeKind = kindTyConType openTypeKindTyCon argTypeKind = kindTyConType argTypeKindTyCon -ubxTupleKind = kindTyConType ubxTupleKindTyCon +ubxTupleKind = kindTyConType ubxTupleKindTyCon constraintKind = kindTyConType constraintKindTyCon -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ @@ -406,15 +420,13 @@ Note [The ~# TyCon) ~~~~~~~~~~~~~~~~~~~~ There is a perfectly ordinary type constructor ~# that represents the type of coercions (which, remember, are values). For example - Refl Int :: ~# Int Int + Refl Int :: ~# * Int Int -Atcually it is not quite "perfectly ordinary" because it is kind-polymorphic: - Refl Maybe :: ~# Maybe Maybe +It is a kind-polymorphic type constructor like Any: + Refl Maybe :: ~# (* -> *) Maybe Maybe -So the true kind of ~# :: forall k. k -> k -> #. But we don't have -polymorphic kinds (yet). However, (~) really only appears saturated in -which case there is no problem in finding the kind of (ty1 ~# ty2). So -we check that in CoreLint (and, in an assertion, in Kind.typeKind). +(~) only appears saturated. So we check that in CoreLint (and, in an +assertion, in Kind.typeKind). Note [The State# TyCon] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -436,7 +448,10 @@ statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep eqPrimTyCon :: TyCon -- The representation type for equality predicates -- See Note [The ~# TyCon] -eqPrimTyCon = pcPrimTyCon eqPrimTyConName 2 VoidRep +eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind 3 VoidRep + where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind + kv = kKiVar + k = mkTyVarTy kv \end{code} RealWorld is deeply magical. It is *primitive*, but it is not @@ -606,7 +621,7 @@ threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep Note [Any types] ~~~~~~~~~~~~~~~~ -The type constructor Any::* has these properties +The type constructor Any of kind forall k. k -> k has these properties: * It is defined in module GHC.Prim, and exported so that it is available to users. For this reason it's treated like any other @@ -629,31 +644,18 @@ The type constructor Any::* has these properties For example length Any [] See Note [Strangely-kinded void TyCons] -In addition, we have a potentially-infinite family of types, one for -each kind /other than/ *, needed to instantiate otherwise -un-constrained type variables of kinds other than *. This is a bit -like tuples; there is a potentially-infinite family. They have slightly -different characteristics to Any::*: - - * They are built with TyCon.AnyTyCon - * They have non-user-writable names like "Any(*->*)" - * They are not exported by GHC.Prim - * They are uninhabited (of course; not kind *) - * They have a unique derived from their OccName (see Note [Uniques of Any]) - * Their Names do not live in the global name cache - -Note [Uniques of Any] -~~~~~~~~~~~~~~~~~~~~~ -Although Any(*->*), say, doesn't have a binding site, it still needs -to have a Unique. Unlike tuples (which are also an infinite family) -there is no convenient way to index them, so we use the Unique from -their OccName instead. That should be unique, - - both wrt each other, because their strings differ - - - and wrt any other Name, because Names get uniques with - various 'char' tags, but the OccName of Any will - get a Unique built with mkTcOccUnique, which has a particular 'char' - tag; see Unique.mkTcOccUnique! +Note [Any kinds] +~~~~~~~~~~~~~~~~ + +The type constructor AnyK (of sort BOX) is used internally only to zonk kind +variables with no constraints on them. It appears in similar circumstances to +Any, but at the kind level. For example: + + type family Length (l :: [k]) :: Nat + type instance Length [] = Zero + +Length is kind-polymorphic, and when applied to the empty (promoted) list it +will be supplied the kind AnyL: Length AnyK []. Note [Strangely-kinded void TyCons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -683,25 +685,9 @@ anyTy :: Type anyTy = mkTyConTy anyTyCon anyTyCon :: TyCon -anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep +anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep + where kind = ForAllTy kKiVar (mkTyVarTy kKiVar) anyTypeOfKind :: Kind -> Type -anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) [] - -anyTyConOfKind :: Kind -> TyCon --- Map all superkinds of liftedTypeKind to liftedTypeKind -anyTyConOfKind kind - | isLiftedTypeKind kind = anyTyCon - | otherwise = tycon - where - -- Derive the name from the kind, thus: - -- Any(*->*), Any(*->*->*) - -- These are names that can't be written by the user, - -- and are not allocated in the global name cache - str = "Any" ++ showSDoc (pprParendKind kind) - - occ = mkTcOcc str - uniq = getUnique occ -- See Note [Uniques of Any] - name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax - tycon = mkAnyTyCon name kind +anyTypeOfKind kind = mkTyConApp anyTyCon [kind] \end{code} diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 54acefc087..c6991e1591 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -420,16 +420,25 @@ mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_ip \begin{code} eqTyCon :: TyCon eqTyCon = mkAlgTyCon eqTyConName - (mkArrowKinds [openTypeKind, openTypeKind] constraintKind) - [alphaTyVar, betaTyVar] + (ForAllTy kv $ mkArrowKinds [k, k] constraintKind) + [kv, a, b] [] -- No stupid theta (DataTyCon [eqBoxDataCon] False) NoParentTyCon NonRecursive False - + where + kv = kKiVar + k = mkTyVarTy kv + a:b:_ = tyVarList k + eqBoxDataCon :: DataCon -eqBoxDataCon = pcDataCon eqBoxDataConName [alphaTyVar, betaTyVar] [TyConApp eqPrimTyCon [mkTyVarTy alphaTyVar, mkTyVarTy betaTyVar]] eqTyCon +eqBoxDataCon = pcDataCon eqBoxDataConName args [TyConApp eqPrimTyCon (map mkTyVarTy args)] eqTyCon + where + kv = kKiVar + k = mkTyVarTy kv + a:b:_ = tyVarList k + args = [kv, a, b] \end{code} \begin{code} diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 5d53713225..fa3a287432 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1762,13 +1762,13 @@ primtype BCO# {Primitive bytecode type.} primop AddrToAnyOp "addrToAny#" GenPrimOp - Addr# -> (# Any #) + Addr# -> (# a #) {Convert an {\tt Addr\#} to a followable Any type.} with code_size = 0 primop MkApUpd0_Op "mkApUpd0#" GenPrimOp - BCO# -> (# Any #) + BCO# -> (# a #) with out_of_line = True @@ -1849,7 +1849,7 @@ pseudoop "lazy" Like {\tt seq}, the argument of {\tt lazy} can have an unboxed type. } -primtype Any +primtype Any a { The type constructor {\tt Any} is type to which you can unsafely coerce any lifted type, and back. @@ -1880,6 +1880,9 @@ primtype Any into interface files, we'll get a crash; at least until we add interface-file syntax to support them. } +primtype AnyK + { JPM Todo } + pseudoop "unsafeCoerce#" a -> b { The function {\tt unsafeCoerce\#} allows you to side-step the typechecker entirely. That diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index faecd40b53..51cd09fb07 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -696,7 +696,7 @@ renameSig ctxt sig@(GenericSig vs ty) ; return (GenericSig new_v new_ty) } renameSig _ (SpecInstSig ty) - = do { new_ty <- rnLHsType (text "In a SPECIALISE instance pragma") ty + = do { new_ty <- rnLHsType SpecInstSigCtx ty ; return (SpecInstSig new_ty) } -- {-# SPECIALISE #-} pragmas can refer to imported Ids diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index c6ab6bb592..c919e46972 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -14,7 +14,7 @@ module RnEnv ( newTopSrcBinder, lookupLocatedTopBndrRn, lookupTopBndrRn, - lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe, + lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe, lookupPromotedOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn, @@ -32,14 +32,16 @@ module RnEnv ( addLocalFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, - bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn, + extendTyVarEnvFVRn, checkDupRdrNames, checkDupAndShadowedRdrNames, checkDupNames, checkDupAndShadowedNames, addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, - dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg + dataTcOccs, unknownNameErr, kindSigErr, polyKindsErr, perhapsForallMsg, + + HsDocContext(..), docOfHsDocContext ) where #include "HsVersions.h" @@ -444,31 +446,61 @@ lookupLocalOccRn_maybe rdr_name ; return (lookupLocalRdrEnv local_env rdr_name) } -- lookupOccRn looks up an occurrence of a RdrName +lookupOccRn :: RdrName -> RnM Name +lookupOccRn rdr_name = do + opt_name <- lookupOccRn_maybe rdr_name + maybe (unboundName WL_Any rdr_name) return opt_name + +-- lookupPromotedOccRn looks up an optionally promoted RdrName. +lookupPromotedOccRn :: RdrName -> RnM Name +-- see Note [Demotion] in OccName +lookupPromotedOccRn rdr_name = do { + -- 1. lookup the name + opt_name <- lookupOccRn_maybe rdr_name + ; case opt_name of + -- 1.a. we found it! + Just name -> return name + -- 1.b. we did not find it -> 2 + Nothing -> do { + ; -- 2. maybe it was implicitly promoted + case demoteRdrName rdr_name of + -- 2.a it was not in a promoted namespace + Nothing -> err + -- 2.b let's try every thing again -> 3 + Just demoted_rdr_name -> do { + ; poly_kinds <- xoptM Opt_PolyKinds + -- 3. lookup again + ; opt_demoted_name <- lookupOccRn_maybe demoted_rdr_name ; + ; case opt_demoted_name of + -- 3.a. it was implicitly promoted, but confirm that we can promote + -- JPM: We could try to suggest turning on PolyKinds here + Just demoted_name -> if poly_kinds then return demoted_name else err + -- 3.b. use rdr_name to have a correct error message + Nothing -> err } } } + where err = unboundName WL_Any rdr_name + +-- lookupOccRn looks up an occurrence of a RdrName lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) lookupOccRn_maybe rdr_name = do { local_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv local_env rdr_name of - Just name -> return (Just name) - Nothing -> lookupGlobalOccRn_maybe rdr_name } - -lookupOccRn :: RdrName -> RnM Name -lookupOccRn rdr_name - = do { mb_name <- lookupOccRn_maybe rdr_name + ; case lookupLocalRdrEnv local_env rdr_name of { + Just name -> return (Just name) ; + Nothing -> do + { mb_name <- lookupGlobalOccRn_maybe rdr_name ; case mb_name of { - Just n -> return n ; - Nothing -> do - - { -- We allow qualified names on the command line to refer to - -- *any* name exported by any module in scope, just as if there - -- was an "import qualified M" declaration for every module. - allow_qual <- doptM Opt_ImplicitImportQualified + Just name -> return (Just name) ; + Nothing -> do + { -- We allow qualified names on the command line to refer to + -- *any* name exported by any module in scope, just as if there + -- was an "import qualified M" declaration for every module. + allow_qual <- doptM Opt_ImplicitImportQualified ; is_ghci <- getIsGHCi -- This test is not expensive, -- and only happens for failed lookups ; if isQual rdr_name && allow_qual && is_ghci then lookupQualifiedName rdr_name else do { traceRn (text "lookupOccRn" <+> ppr rdr_name) - ; unboundName WL_Any rdr_name } } } } + ; return Nothing } } } } } } lookupGlobalOccRn :: RdrName -> RnM Name @@ -564,7 +596,7 @@ addUsedRdrNames rdrs -- A qualified name on the command line can refer to any module at all: we -- try to load the interface if we don't already have it. -lookupQualifiedName :: RdrName -> RnM Name +lookupQualifiedName :: RdrName -> RnM (Maybe Name) lookupQualifiedName rdr_name | Just (mod,occ) <- isQual_maybe rdr_name -- Note: we want to behave as we would for a source file import here, @@ -575,9 +607,9 @@ lookupQualifiedName rdr_name | avail <- mi_exports iface, name <- availNames avail, nameOccName name == occ ] of - (n:ns) -> ASSERT (null ns) return n + (n:ns) -> ASSERT (null ns) return (Just n) _ -> do { traceRn (text "lookupQualified" <+> ppr rdr_name) - ; unboundName WL_Any rdr_name } + ; return Nothing } | otherwise = pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name) @@ -962,28 +994,6 @@ bindLocatedLocalsFV rdr_names enclosed_scope return (thing, delFVs names fvs) ------------------------------------- -bindTyVarsFV :: [LHsTyVarBndr RdrName] - -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -bindTyVarsFV tyvars thing_inside - = bindTyVarsRn tyvars $ \ tyvars' -> - do { (res, fvs) <- thing_inside tyvars' - ; return (res, delFVs (map hsLTyVarName tyvars') fvs) } - -bindTyVarsRn :: [LHsTyVarBndr RdrName] - -> ([LHsTyVarBndr Name] -> RnM a) - -> RnM a --- Haskell-98 binding of type variables; e.g. within a data type decl -bindTyVarsRn tyvar_names enclosed_scope - = bindLocatedLocalsRn located_tyvars $ \ names -> - do { kind_sigs_ok <- xoptM Opt_KindSignatures - ; unless (null kinded_tyvars || kind_sigs_ok) - (mapM_ (addErr . kindSigErr) kinded_tyvars) - ; enclosed_scope (zipWith replaceLTyVarName tyvar_names names) } - where - located_tyvars = hsLTyVarLocNames tyvar_names - kinded_tyvars = [n | L _ (KindedTyVar n _) <- tyvar_names] - bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a -- Find the type variables in the pattern type -- signatures that must be brought into scope @@ -1402,6 +1412,11 @@ kindSigErr thing = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing)) 2 (ptext (sLit "Perhaps you intended to use -XKindSignatures")) +polyKindsErr :: Outputable a => a -> SDoc +polyKindsErr thing + = hang (ptext (sLit "Illegal kind:") <+> quotes (ppr thing)) + 2 (ptext (sLit "Perhaps you intended to use -XPolyKinds")) + badQualBndrErr :: RdrName -> SDoc badQualBndrErr rdr_name @@ -1412,3 +1427,56 @@ opDeclErr n = hang (ptext (sLit "Illegal declaration of a type or class operator") <+> quotes (ppr n)) 2 (ptext (sLit "Use -XTypeOperators to declare operators in type and declarations")) \end{code} + + +%************************************************************************ +%* * +\subsection{Contexts for renaming errors} +%* * +%************************************************************************ + +\begin{code} + +data HsDocContext + = TypeSigCtx SDoc + | PatCtx + | SpecInstSigCtx + | DefaultDeclCtx + | ForeignDeclCtx (Located RdrName) + | DerivDeclCtx + | RuleCtx FastString + | TyDataCtx (Located RdrName) + | TySynCtx (Located RdrName) + | TyFamilyCtx (Located RdrName) + | ConDeclCtx (Located RdrName) + | ClassDeclCtx (Located RdrName) + | ExprWithTySigCtx + | TypBrCtx + | HsTypeCtx + | GHCiCtx + | SpliceTypeCtx (LHsType RdrName) + | ClassInstanceCtx + | VectDeclCtx (Located RdrName) + +docOfHsDocContext :: HsDocContext -> SDoc +docOfHsDocContext (TypeSigCtx doc) = text "In the type signature for" <+> doc +docOfHsDocContext PatCtx = text "In a pattern type-signature" +docOfHsDocContext SpecInstSigCtx = text "In a SPECIALISE instance pragma" +docOfHsDocContext DefaultDeclCtx = text "In a `default' declaration" +docOfHsDocContext (ForeignDeclCtx name) = ptext (sLit "In the foreign declaration for") <+> ppr name +docOfHsDocContext DerivDeclCtx = text "In a deriving declaration" +docOfHsDocContext (RuleCtx name) = text "In the transformation rule" <+> ftext name +docOfHsDocContext (TyDataCtx tycon) = text "In the data type declaration for" <+> quotes (ppr tycon) +docOfHsDocContext (TySynCtx name) = text "In the declaration for type synonym" <+> quotes (ppr name) +docOfHsDocContext (TyFamilyCtx name) = text "In the declaration for type family" <+> quotes (ppr name) +docOfHsDocContext (ConDeclCtx name) = text "In the definition of data constructor" <+> quotes (ppr name) +docOfHsDocContext (ClassDeclCtx name) = text "In the declaration for class" <+> ppr name +docOfHsDocContext ExprWithTySigCtx = text "In an expression type signature" +docOfHsDocContext TypBrCtx = ptext (sLit "In a Template-Haskell quoted type") +docOfHsDocContext HsTypeCtx = text "In a type argument" +docOfHsDocContext GHCiCtx = ptext (sLit "In GHCi input") +docOfHsDocContext (SpliceTypeCtx hs_ty) = ptext (sLit "In the spliced type") <+> ppr hs_ty +docOfHsDocContext ClassInstanceCtx = ptext (sLit "TcSplice.reifyInstances") +docOfHsDocContext (VectDeclCtx tycon) = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon) + +\end{code} diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index f57998ef44..7f863808eb 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -169,8 +169,13 @@ rnExpr (NegApp e _) -- Don't ifdef-GHCI them because we want to fail gracefully -- (not with an rnExpr crash) in a stage-1 compiler. rnExpr e@(HsBracket br_body) - = checkTH e "bracket" `thenM_` - rnBracket br_body `thenM` \ (body', fvs_e) -> + = do + thEnabled <- xoptM Opt_TemplateHaskell + unless thEnabled $ + failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e + , ptext (sLit "Perhaps you intended to use -XTemplateHaskell") ] ) + checkTH e "bracket" + (body', fvs_e) <- rnBracket br_body return (HsBracket body', fvs_e) rnExpr (HsSpliceE splice) @@ -265,12 +270,10 @@ rnExpr (RecordUpd expr rbinds _ _ _) fvExpr `plusFV` fvRbinds) } rnExpr (ExprWithTySig expr pty) - = do { (pty', fvTy) <- rnHsTypeFVs doc pty + = do { (pty', fvTy) <- rnHsTypeFVs ExprWithTySigCtx pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $ rnLExpr expr ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } - where - doc = text "In an expression type signature" rnExpr (HsIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p @@ -280,10 +283,8 @@ rnExpr (HsIf _ p b1 b2) ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnExpr (HsType a) - = rnHsTypeFVs doc a `thenM` \ (t, fvT) -> + = rnHsTypeFVs HsTypeCtx a `thenM` \ (t, fvT) -> return (HsType t, fvT) - where - doc = text "In a type argument" rnExpr (ArithSeq _ seq) = rnArithSeq seq `thenM` \ (new_seq, fvs) -> @@ -590,14 +591,14 @@ rnArithSeq (FromThenTo expr1 expr2 expr3) \begin{code} rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars) -rnBracket (VarBr n) +rnBracket (VarBr flg n) = do { name <- lookupOccRn n ; this_mod <- getModule ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes do { _ <- loadInterfaceForName msg name -- the home interface is loaded, and ; return () } -- this is the only way that is going -- to happen - ; return (VarBr name, unitFV name) } + ; return (VarBr flg name, unitFV name) } where msg = ptext (sLit "Need interface for Template Haskell quoted Name") @@ -606,10 +607,8 @@ rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) -rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t +rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs TypBrCtx t ; return (TypBr t', fvs) } - where - doc = ptext (sLit "In a Template-Haskell quoted type") rnBracket (DecBrL decls) = do { (group, mb_splice) <- findSplice decls diff --git a/compiler/rename/RnExpr.lhs-boot b/compiler/rename/RnExpr.lhs-boot index 2d59537b95..5ca81d6db4 100644 --- a/compiler/rename/RnExpr.lhs-boot +++ b/compiler/rename/RnExpr.lhs-boot @@ -1,4 +1,4 @@ -\begin{code}
+\begin{code} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and @@ -6,19 +6,19 @@ -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details -module RnExpr where
-import HsSyn
-import Name ( Name )
-import NameSet ( FreeVars )
-import RdrName ( RdrName )
-import TcRnTypes
-
-rnLExpr :: LHsExpr RdrName
- -> RnM (LHsExpr Name, FreeVars)
-
-rnStmts :: --forall thing.
- HsStmtContext Name -> [LStmt RdrName]
- -> ([Name] -> RnM (thing, FreeVars))
- -> RnM (([LStmt Name], thing), FreeVars)
-\end{code}
-
+module RnExpr where +import HsSyn +import Name ( Name ) +import NameSet ( FreeVars ) +import RdrName ( RdrName ) +import TcRnTypes + +rnLExpr :: LHsExpr RdrName + -> RnM (LHsExpr Name, FreeVars) + +rnStmts :: --forall thing. + HsStmtContext Name -> [LStmt RdrName] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt Name], thing), FreeVars) +\end{code} + diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index 7b0591dd19..e2369bb776 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -16,6 +16,7 @@ module RnHsSyn( charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name, extractHsTyVars, extractHsTyNames, extractHsTyNames_s, extractFunDepNames, extractHsCtxtTyNames, + extractHsTyVarBndrNames, extractHsTyVarBndrNames_s, -- Free variables hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs @@ -30,6 +31,7 @@ import Name ( Name, getName, isTyVarName ) import NameSet import BasicTypes ( TupleSort ) import SrcLoc +import Panic ( panic ) \end{code} %************************************************************************ @@ -56,6 +58,7 @@ extractFunDepNames :: FunDep Name -> NameSet extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2 extractHsTyNames :: LHsType Name -> NameSet +-- Also extract names in kinds. extractHsTyNames ty = getl ty where @@ -68,22 +71,24 @@ extractHsTyNames ty get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 get (HsIParamTy _ ty) = getl ty get (HsEqTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 - get (HsOpTy ty1 op ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op) + get (HsOpTy ty1 (_, op) ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op) get (HsParTy ty) = getl ty get (HsBangTy _ ty) = getl ty get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds) get (HsTyVar tv) = unitNameSet tv get (HsSpliceTy _ fvs _) = fvs get (HsQuasiQuoteTy {}) = emptyNameSet - get (HsKindSig ty _) = getl ty + get (HsKindSig ty ki) = getl ty `unionNameSets` getl ki get (HsForAllTy _ tvs - ctxt ty) = (extractHsCtxtTyNames ctxt - `unionNameSets` getl ty) - `minusNameSet` - mkNameSet (hsLTyVarNames tvs) + ctxt ty) = extractHsTyVarBndrNames_s tvs + (extractHsCtxtTyNames ctxt + `unionNameSets` getl ty) get (HsDocTy ty _) = getl ty get (HsCoreTy {}) = emptyNameSet -- This probably isn't quite right -- but I don't think it matters + get (HsExplicitListTy _ tys) = extractHsTyNames_s tys + get (HsExplicitTupleTy _ tys) = extractHsTyNames_s tys + get (HsWrapTy {}) = panic "extractHsTyNames" extractHsTyNames_s :: [LHsType Name] -> NameSet extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys @@ -91,6 +96,18 @@ extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet t extractHsCtxtTyNames :: LHsContext Name -> NameSet extractHsCtxtTyNames (L _ ctxt) = foldr (unionNameSets . extractHsTyNames) emptyNameSet ctxt + +extractHsTyVarBndrNames :: LHsTyVarBndr Name -> NameSet +extractHsTyVarBndrNames (L _ (UserTyVar _ _)) = emptyNameSet +extractHsTyVarBndrNames (L _ (KindedTyVar _ ki _)) = extractHsTyNames ki + +extractHsTyVarBndrNames_s :: [LHsTyVarBndr Name] -> NameSet -> NameSet +-- Update the name set 'body' by adding the names in the binders +-- kinds and handling scoping. +extractHsTyVarBndrNames_s [] body = body +extractHsTyVarBndrNames_s (b:bs) body = + (extractHsTyVarBndrNames_s bs body `delFromNameSet` hsTyVarName (unLoc b)) + `unionNameSets` extractHsTyVarBndrNames b \end{code} @@ -125,7 +142,7 @@ hsSigFVs _ = emptyFVs conDeclFVs :: LConDecl Name -> FreeVars conDeclFVs (L _ (ConDecl { con_qvars = tyvars, con_cxt = context, con_details = details, con_res = res_ty})) - = delFVs (map hsLTyVarName tyvars) $ + = extractHsTyVarBndrNames_s tyvars $ extractHsCtxtTyNames context `plusFV` conDetailsFVs details `plusFV` conResTyFVs res_ty diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 5c28f73a56..740acc42c5 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -314,12 +314,11 @@ rnPatAndThen mk (SigPatIn pat ty) = do { patsigs <- liftCps (xoptM Opt_ScopedTypeVariables) ; if patsigs then do { pat' <- rnLPatAndThen mk pat - ; ty' <- liftCpsFV (rnHsTypeFVs tvdoc ty) + ; ty' <- liftCpsFV (rnHsTypeFVs PatCtx ty) ; return (SigPatIn pat' ty') } else do { liftCps (addErr (patSigErr ty)) ; rnPatAndThen mk (unLoc pat) } } - where - tvdoc = text "In a pattern type-signature" + rnPatAndThen mk (LitPat lit) | HsString s <- lit diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 8b34fb4e5b..b6247d449b 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -50,7 +50,7 @@ import SrcLoc import DynFlags import HscTypes ( HscEnv, hsc_dflags ) import ListSetOps ( findDupsEq ) -import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) +import Digraph ( SCC, flattenSCCs, stronglyConnCompFromEdgedVertices ) import Control.Monad import Maybes( orElse ) @@ -359,7 +359,7 @@ rnDefaultDecl (DefaultDecl tys) = do { (tys', fvs) <- mapFvRn (rnHsTypeFVs doc_str) tys ; return (DefaultDecl tys', fvs) } where - doc_str = text "In a `default' declaration" + doc_str = DefaultDeclCtx \end{code} %********************************************************* @@ -373,7 +373,7 @@ rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) rnHsForeignDecl (ForeignImport name ty _ spec) = do { topEnv :: HscEnv <- getTopEnv ; name' <- lookupLocatedTopBndrRn name - ; (ty', fvs) <- rnHsTypeFVs (fo_decl_msg name) ty + ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty -- Mark any PackageTarget style imports as coming from the current package ; let packageId = thisPackage $ hsc_dflags topEnv @@ -383,16 +383,12 @@ rnHsForeignDecl (ForeignImport name ty _ spec) rnHsForeignDecl (ForeignExport name ty _ spec) = do { name' <- lookupLocatedOccRn name - ; (ty', fvs) <- rnHsTypeFVs (fo_decl_msg name) ty + ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') } -- NB: a foreign export is an *occurrence site* for name, so -- we add it to the free-variable list. It might, for example, -- be imported from another module -fo_decl_msg :: Located RdrName -> SDoc -fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name - - -- | For Windows DLLs we need to know what packages imported symbols are from -- to generate correct calls. Imported symbols are tagged with the current -- package, so if they get inlined across a package boundry we'll still @@ -546,7 +542,7 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') } where - doc = text "In the transformation rule" <+> ftext rule_name + doc = RuleCtx rule_name get_var (RuleBndr v) = v get_var (RuleBndrSig v _) = v @@ -715,7 +711,13 @@ rnTyClDecls tycl_ds all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs - ; return (map flattenSCC sccs, all_fvs) } + ; return ([flattenSCCs sccs], all_fvs) } +-- JPM: This is wrong. We are calculating the SCCs but then ignore them and +-- merge into a single, big group. This is a quick fix to allow +-- mutually-recursive types across modules to work, given the new way of kind +-- checking and type checking declarations in groups (see +-- Note [Grouping of type and class declarations] in TcTyClsDecls). This "fix" +-- fully breaks promotion; we will fix that later. rnTyClDecl :: Maybe Name -- Just cls => this TyClDecl is nested -- inside an *instance decl* for cls @@ -731,12 +733,16 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name}) -- and "data family"), both top level and (for an associated type) -- in a class decl rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars - , tcdFlavour = flav, tcdKind = kind }) - = bindQTvs mb_cls tyvars $ \tyvars' -> + , tcdFlavour = flav, tcdKind = kind }) + = bindQTvs fmly_doc mb_cls tyvars $ \tyvars' -> do { tycon' <- lookupLocatedTopBndrRn tycon + ; kind' <- rnLHsMaybeKind fmly_doc kind + ; let fv_kind = maybe emptyFVs extractHsTyNames kind' + fvs = extractHsTyVarBndrNames_s tyvars' fv_kind ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars' - , tcdFlavour = flav, tcdKind = kind } - , emptyFVs) } + , tcdFlavour = flav, tcdKind = kind' } + , fvs) } + where fmly_doc = TyFamilyCtx tycon -- "data", "newtype", "data instance, and "newtype instance" declarations -- both top level and (for an associated type) in an instance decl @@ -745,17 +751,19 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, tcdTyPats = typats, tcdCons = condecls, tcdKindSig = sig, tcdDerivs = derivs} = do { tycon' <- lookupTcdName mb_cls tydecl + ; sig' <- rnLHsMaybeKind data_doc sig ; checkTc (h98_style || null (unLoc context)) (badGadtStupidTheta tycon) ; ((tyvars', context', typats', derivs'), stuff_fvs) - <- bindQTvs mb_cls tyvars $ \ tyvars' -> do + <- bindQTvs data_doc mb_cls tyvars $ \ tyvars' -> do -- Checks for distinct tyvars { context' <- rnContext data_doc context ; (typats', fvs1) <- rnTyPats data_doc tycon' typats ; (derivs', fvs2) <- rn_derivs derivs ; let fvs = fvs1 `plusFV` fvs2 `plusFV` extractHsCtxtTyNames context' + `plusFV` maybe emptyFVs extractHsTyNames sig' ; return ((tyvars', context', typats', derivs'), fvs) } -- For the constructor declarations, bring into scope the tyvars @@ -772,7 +780,7 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, ; return (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', tcdTyVars = tyvars', - tcdTyPats = typats', tcdKindSig = sig, + tcdTyPats = typats', tcdKindSig = sig', tcdCons = condecls', tcdDerivs = derivs'}, con_fvs `plusFV` stuff_fvs) } @@ -780,8 +788,8 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, h98_style = case condecls of -- Note [Stupid theta] L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False _ -> True - - data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) + + data_doc = TyDataCtx tycon rn_derivs Nothing = return (Nothing, emptyFVs) rn_derivs (Just ds) = do { ds' <- rnLHsTypes data_doc ds @@ -790,16 +798,16 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, -- "type" and "type instance" declarations rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name, tcdTyPats = typats, tcdSynRhs = ty}) - = bindQTvs mb_cls tyvars $ \ tyvars' -> do + = bindQTvs syn_doc mb_cls tyvars $ \ tyvars' -> do { -- Checks for distinct tyvars name' <- lookupTcdName mb_cls tydecl ; (typats',fvs1) <- rnTyPats syn_doc name' typats ; (ty', fvs2) <- rnHsTypeFVs syn_doc ty - ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' - , tcdTyPats = typats', tcdSynRhs = ty'}, - fvs1 `plusFV` fvs2) } + ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' + , tcdTyPats = typats', tcdSynRhs = ty'} + , extractHsTyVarBndrNames_s tyvars' (fvs1 `plusFV` fvs2)) } where - syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) + syn_doc = TySynCtx name rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, @@ -810,10 +818,10 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, -- Tyvars scope over superclass context and method signatures ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs) - <- bindTyVarsFV tyvars $ \ tyvars' -> do + <- bindTyVarsFV cls_doc tyvars $ \ tyvars' -> do -- Checks for distinct tyvars { context' <- rnContext cls_doc context - ; fds' <- rnFds cls_doc fds + ; fds' <- rnFds (docOfHsDocContext cls_doc) fds ; let rn_at = rnTyClDecl (Just cls') ; (ats', fv_ats) <- mapAndUnzipM (wrapLocFstM rn_at) ats ; sigs' <- renameSigs (ClsDeclCtxt cls') sigs @@ -859,21 +867,20 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', tcdDocs = docs'}, - meth_fvs `plusFV` stuff_fvs) } + extractHsTyVarBndrNames_s tyvars' (meth_fvs `plusFV` stuff_fvs)) } where - cls_doc = text "In the declaration for class" <+> ppr lcls + cls_doc = ClassDeclCtx lcls -bindQTvs :: Maybe Name -> [LHsTyVarBndr RdrName] +bindQTvs :: HsDocContext -> Maybe Name -> [LHsTyVarBndr RdrName] -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) --- For *associated* type/data family instances (in an instance decl) --- don't quantify over the already-in-scope type variables -bindQTvs mb_cls tyvars thing_inside +bindQTvs doc mb_cls tyvars thing_inside | isNothing mb_cls -- Not associated - = bindTyVarsFV tyvars thing_inside + = bindTyVarsFV doc tyvars thing_inside | otherwise -- Associated = do { let tv_rdr_names = map hsLTyVarLocName tyvars + -- *All* the free vars of the family patterns -- Check for duplicated bindings -- This test is irrelevant for data/type *instances*, where the tyvars @@ -882,9 +889,10 @@ bindQTvs mb_cls tyvars thing_inside ; mapM_ dupBoundTyVar (findDupRdrNames tv_rdr_names) ; rdr_env <- getLocalRdrEnv + ; tv_ns <- mapM (mk_tv_name rdr_env) tv_rdr_names - ; (thing, fvs) <- bindLocalNamesFV tv_ns $ - thing_inside (zipWith replaceLTyVarName tyvars tv_ns) + ; tyvars' <- zipWithM (\old new -> replaceLTyVarName old new (rnLHsKind doc)) tyvars tv_ns + ; (thing, fvs) <- bindLocalNamesFV tv_ns $ thing_inside tyvars' -- Check that the RHS of the decl mentions only type variables -- bound on the LHS. For example, this is not ok @@ -942,10 +950,21 @@ depAnalTyClDecls ds_w_fvs edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs)) | (d, fvs) <- ds_w_fvs ] get_assoc n = lookupNameEnv assoc_env n `orElse` n - assoc_env = mkNameEnv [ (tcdName assoc_decl, cls_name) - | (L _ (ClassDecl { tcdLName = L _ cls_name - , tcdATs = ats }) ,_) <- ds_w_fvs - , L _ assoc_decl <- ats ] + assoc_env = mkNameEnv assoc_env_list + -- We also need to consider data constructor names since they may + -- appear in types because of promotion. + assoc_env_list = do + (L _ d, _) <- ds_w_fvs + case d of + ClassDecl { tcdLName = L _ cls_name + , tcdATs = ats } -> do + L _ assoc_decl <- ats + return (tcdName assoc_decl, cls_name) + TyData { tcdLName = L _ data_name + , tcdCons = cons } -> do + L _ dc <- cons + return (unLoc (con_name dc), data_name) + _ -> [] \end{code} Note [Dependency analysis of type and class decls] @@ -969,7 +988,7 @@ is jolly confusing. See Trac #4875 %********************************************************* \begin{code} -rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars) +rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars) -- Although, we are processing type patterns here, all type variables will -- already be in scope (they are the same as in the 'tcdTyVars' field of the -- type declaration to which these patterns belong) @@ -1009,22 +1028,22 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs -- With Implicit, find the mentioned ones, and use them as binders ; new_tvs <- case expl of Implicit -> return (userHsTyVarBndrs mentioned_tvs) - Explicit -> do { warnUnusedForAlls doc tvs mentioned_tvs + Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs mentioned_tvs ; return tvs } ; mb_doc' <- rnMbLHsDoc mb_doc - ; bindTyVarsRn new_tvs $ \new_tyvars -> do + ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do { new_context <- rnContext doc cxt ; new_details <- rnConDeclDetails doc details ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }} where - doc = text "In the definition of data constructor" <+> quotes (ppr name) + doc = ConDeclCtx name get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy (HsBoxyTuple liftedTypeKind) tys)) -rnConResult :: SDoc +rnConResult :: HsDocContext -> HsConDetails (LHsType Name) [ConDeclField Name] -> ResType RdrName -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], @@ -1044,10 +1063,10 @@ rnConResult doc details (ResTyGADT ty) -- See Note [Sorting out the result type] in RdrHsSyn ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False }) - (addErr (badRecResTy doc)) + (addErr (badRecResTy (docOfHsDocContext doc))) ; return (details', ResTyGADT res_ty) } -rnConDeclDetails :: SDoc +rnConDeclDetails :: HsDocContext -> HsConDetails (LHsType RdrName) [ConDeclField RdrName] -> RnM (HsConDetails (LHsType Name) [ConDeclField Name]) rnConDeclDetails doc (PrefixCon tys) diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 3607170e70..df6008b574 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -14,6 +14,7 @@ module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, + rnHsKind, rnLHsKind, rnLHsMaybeKind, rnHsSigType, rnLHsInstType, rnHsTypeFVs, rnConDeclFields, rnIPName, @@ -22,7 +23,10 @@ module RnTypes ( checkPrecMatch, checkSectionPrec, warnUnusedForAlls, -- Splice related stuff - rnSplice, checkTH + rnSplice, checkTH, + + -- Binding related stuff + bindTyVarsRn, bindTyVarsFV ) where import {-# SOURCE #-} RnExpr( rnLExpr ) @@ -33,7 +37,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) import DynFlags import HsSyn import RdrHsSyn ( extractHsRhoRdrTyVars ) -import RnHsSyn ( extractHsTyNames ) +import RnHsSyn ( extractHsTyNames, extractHsTyVarBndrNames_s ) import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import TcRnMonad @@ -50,7 +54,7 @@ import BasicTypes ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFi Fixity(..), FixityDirection(..) ) import Outputable import FastString -import Control.Monad ( unless ) +import Control.Monad ( unless, zipWithM ) #include "HsVersions.h" \end{code} @@ -65,7 +69,7 @@ to break several loop. %********************************************************* \begin{code} -rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnHsTypeFVs :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) rnHsTypeFVs doc_str ty = do ty' <- rnLHsType doc_str ty return (ty', extractHsTyNames ty') @@ -74,12 +78,12 @@ rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) -- rnHsSigType is used for source-language type signatures, -- which use *implicit* universal quantification. rnHsSigType doc_str ty - = rnLHsType (text "In the type signature for" <+> doc_str) ty + = rnLHsType (TypeSigCtx doc_str) ty rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) -- Rename the type in an instance or standalone deriving decl rnLHsInstType doc_str ty - = do { ty' <- rnLHsType doc_str ty + = do { ty' <- rnLHsType (TypeSigCtx doc_str) ty ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty)) ; return ty' } where @@ -96,12 +100,28 @@ rnHsType is here because we call it from loadInstDecl, and I didn't want a gratuitous knot. \begin{code} -rnLHsType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) -rnLHsType doc = wrapLocM (rnHsType doc) - -rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name) - -rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do +rnLHsTyKi :: Bool -- True <=> renaming a type, False <=> a kind + -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name) +rnLHsTyKi isType doc = wrapLocM (rnHsTyKi isType doc) + +rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name) +rnLHsType = rnLHsTyKi True +rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name) +rnLHsKind = rnLHsTyKi False +rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) -> RnM (Maybe (LHsKind Name)) +rnLHsMaybeKind _ Nothing = return Nothing +rnLHsMaybeKind doc (Just k) = do + k' <- rnLHsKind doc k + return (Just k') + +rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name) +rnHsType = rnHsTyKi True +rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name) +rnHsKind = rnHsTyKi False + +rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name) + +rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty) = ASSERT ( isType ) do -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} @@ -118,120 +138,141 @@ rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do rnForAll doc Implicit tyvar_bndrs ctxt ty -rnHsType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau) - = do { -- Explicit quantification. +rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau) + = ASSERT ( isType ) do { -- Explicit quantification. -- Check that the forall'd tyvars are actually -- mentioned in the type, and produce a warning if not let mentioned = extractHsRhoRdrTyVars ctxt tau in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty) - ; warnUnusedForAlls (in_type_doc $$ doc) forall_tyvars mentioned + ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned ; -- rnForAll does the rest rnForAll doc Explicit forall_tyvars ctxt tau } -rnHsType _ (HsTyVar tyvar) = do - tyvar' <- lookupOccRn tyvar - return (HsTyVar tyvar') +rnHsTyKi isType _ (HsTyVar rdr_name) = do + -- We use lookupOccRn in kinds because all the names are in + -- TcClsName, and we don't want to look in DataName. + name <- (if isType then lookupPromotedOccRn else lookupOccRn) rdr_name + return (HsTyVar name) -- If we see (forall a . ty), without foralls on, the forall will give -- a sensible error message, but we don't want to complain about the dot too -- Hence the jiggery pokery with ty1 -rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2) - = setSrcSpan loc $ +rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2) + = ASSERT ( isType ) setSrcSpan loc $ do { ops_ok <- xoptM Opt_TypeOperators ; op' <- if ops_ok - then lookupOccRn op + then lookupPromotedOccRn op else do { addErr (opTyErr op ty) ; return (mkUnboundName op) } -- Avoid double complaint ; let l_op' = L loc op' ; fix <- lookupTyFixityRn l_op' ; ty1' <- rnLHsType doc ty1 ; ty2' <- rnLHsType doc ty2 - ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) op' fix ty1' ty2' } + ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) op' fix ty1' ty2' } -rnHsType doc (HsParTy ty) = do - ty' <- rnLHsType doc ty +rnHsTyKi isType doc (HsParTy ty) = do + ty' <- rnLHsTyKi isType doc ty return (HsParTy ty') -rnHsType doc (HsBangTy b ty) - = do { ty' <- rnLHsType doc ty +rnHsTyKi isType doc (HsBangTy b ty) + = ASSERT ( isType ) do { ty' <- rnLHsType doc ty ; return (HsBangTy b ty') } -rnHsType doc (HsRecTy flds) - = do { flds' <- rnConDeclFields doc flds +rnHsTyKi isType doc (HsRecTy flds) + = ASSERT ( isType ) do { flds' <- rnConDeclFields doc flds ; return (HsRecTy flds') } -rnHsType doc (HsFunTy ty1 ty2) = do - ty1' <- rnLHsType doc ty1 +rnHsTyKi isType doc (HsFunTy ty1 ty2) = do + ty1' <- rnLHsTyKi isType doc ty1 -- Might find a for-all as the arg of a function type - ty2' <- rnLHsType doc ty2 + ty2' <- rnLHsTyKi isType doc ty2 -- Or as the result. This happens when reading Prelude.hi -- when we find return :: forall m. Monad m -> forall a. a -> m a -- Check for fixity rearrangements - mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' - -rnHsType doc (HsListTy ty) = do - ty' <- rnLHsType doc ty + if isType + then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' + else return (HsFunTy ty1' ty2') + +rnHsTyKi isType doc listTy@(HsListTy ty) = do + poly_kinds <- xoptM Opt_PolyKinds + unless (poly_kinds || isType) (addErr (polyKindsErr listTy)) + ty' <- rnLHsTyKi isType doc ty return (HsListTy ty') -rnHsType doc (HsKindSig ty k) - = do { kind_sigs_ok <- xoptM Opt_KindSignatures +rnHsTyKi isType doc (HsKindSig ty k) + = ASSERT ( isType ) do { + ; kind_sigs_ok <- xoptM Opt_KindSignatures ; unless kind_sigs_ok (addErr (kindSigErr ty)) ; ty' <- rnLHsType doc ty - ; return (HsKindSig ty' k) } + ; k' <- rnLHsKind doc k + ; return (HsKindSig ty' k') } -rnHsType doc (HsPArrTy ty) = do +rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do ty' <- rnLHsType doc ty return (HsPArrTy ty') -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsType doc (HsTupleTy tup_con tys) = do - tys' <- mapM (rnLHsType doc) tys +rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do + poly_kinds <- xoptM Opt_PolyKinds + unless (poly_kinds || isType) (addErr (polyKindsErr tupleTy)) + tys' <- mapM (rnLHsTyKi isType doc) tys return (HsTupleTy tup_con tys') -rnHsType doc (HsAppTy ty1 ty2) = do - ty1' <- rnLHsType doc ty1 - ty2' <- rnLHsType doc ty2 +rnHsTyKi isType doc (HsAppTy ty1 ty2) = do + ty1' <- rnLHsTyKi isType doc ty1 + ty2' <- rnLHsTyKi isType doc ty2 return (HsAppTy ty1' ty2') -rnHsType doc (HsIParamTy n ty) = do +rnHsTyKi isType doc (HsIParamTy n ty) = ASSERT( isType ) do ty' <- rnLHsType doc ty n' <- rnIPName n return (HsIParamTy n' ty') -rnHsType doc (HsEqTy ty1 ty2) = do +rnHsTyKi isType doc (HsEqTy ty1 ty2) = ASSERT( isType ) do ty1' <- rnLHsType doc ty1 ty2' <- rnLHsType doc ty2 return (HsEqTy ty1' ty2') -rnHsType _ (HsSpliceTy sp _ k) - = do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs +rnHsTyKi isType _ (HsSpliceTy sp _ k) + = ASSERT ( isType ) do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs ; return (HsSpliceTy sp' fvs k) } -rnHsType doc (HsDocTy ty haddock_doc) = do +rnHsTyKi isType doc (HsDocTy ty haddock_doc) = ASSERT ( isType ) do ty' <- rnLHsType doc ty haddock_doc' <- rnLHsDoc haddock_doc return (HsDocTy ty' haddock_doc') #ifndef GHCI -rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty) +rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty) #else -rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq +rnHsTyKi isType doc (HsQuasiQuoteTy qq) = ASSERT ( isType ) do { ty <- runQuasiQuoteType qq ; rnHsType doc (unLoc ty) } #endif -rnHsType _ (HsCoreTy ty) = return (HsCoreTy ty) +rnHsTyKi isType _ (HsCoreTy ty) = ASSERT ( isType ) return (HsCoreTy ty) +rnHsTyKi _ _ (HsWrapTy {}) = panic "rnHsTyKi" + +rnHsTyKi isType doc (HsExplicitListTy k tys) = + ASSERT( isType ) + do tys' <- mapM (rnLHsType doc) tys + return (HsExplicitListTy k tys') + +rnHsTyKi isType doc (HsExplicitTupleTy kis tys) = + ASSERT( isType ) + do tys' <- mapM (rnLHsType doc) tys + return (HsExplicitTupleTy kis tys') -------------- -rnLHsTypes :: SDoc -> [LHsType RdrName] +rnLHsTypes :: HsDocContext -> [LHsType RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name] rnLHsTypes doc tys = mapM (rnLHsType doc) tys \end{code} \begin{code} -rnForAll :: SDoc -> HsExplicitFlag -> [LHsTyVarBndr RdrName] +rnForAll :: HsDocContext -> HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name) rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty @@ -244,17 +285,41 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty -- of kind *. rnForAll doc exp forall_tyvars ctxt ty - = bindTyVarsRn forall_tyvars $ \ new_tyvars -> do + = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do new_ctxt <- rnContext doc ctxt new_ty <- rnLHsType doc ty return (HsForAllTy exp new_tyvars new_ctxt new_ty) -- Retain the same implicit/explicit flag as before -- so that we can later print it correctly -rnConDeclFields :: SDoc -> [ConDeclField RdrName] -> RnM [ConDeclField Name] +bindTyVarsFV :: HsDocContext -> [LHsTyVarBndr RdrName] + -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindTyVarsFV doc tyvars thing_inside + = bindTyVarsRn doc tyvars $ \ tyvars' -> + do { (res, fvs) <- thing_inside tyvars' + ; return (res, extractHsTyVarBndrNames_s tyvars' fvs) } + +bindTyVarsRn :: HsDocContext -> [LHsTyVarBndr RdrName] + -> ([LHsTyVarBndr Name] -> RnM a) + -> RnM a +-- Haskell-98 binding of type variables; e.g. within a data type decl +bindTyVarsRn doc tyvar_names enclosed_scope + = bindLocatedLocalsRn located_tyvars $ \ names -> + do { kind_sigs_ok <- xoptM Opt_KindSignatures + ; unless (null kinded_tyvars || kind_sigs_ok) + (mapM_ (addErr . kindSigErr) kinded_tyvars) + ; tyvar_names' <- zipWithM replace tyvar_names names + ; enclosed_scope tyvar_names' } + where + replace (L loc n1) n2 = replaceTyVarName n1 n2 (rnLHsKind doc) >>= return . L loc + located_tyvars = hsLTyVarLocNames tyvar_names + kinded_tyvars = [n | L _ (KindedTyVar n _ _) <- tyvar_names] + +rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] -> RnM [ConDeclField Name] rnConDeclFields doc fields = mapM (rnField doc) fields -rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name) +rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name) rnField doc (ConDeclField name ty haddock_doc) = do { new_name <- lookupLocatedTopBndrRn name ; new_ty <- rnLHsType doc ty @@ -269,10 +334,10 @@ rnField doc (ConDeclField name ty haddock_doc) %********************************************************* \begin{code} -rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name) +rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name) rnContext doc = wrapLocM (rnContext' doc) -rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name) +rnContext' :: HsDocContext -> HsContext RdrName -> RnM (HsContext Name) rnContext' doc ctxt = mapM (rnLHsType doc) ctxt rnIPName :: IPName RdrName -> RnM (IPName Name) @@ -311,10 +376,10 @@ mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name) -> Name -> Fixity -> LHsType Name -> LHsType Name -> RnM (HsType Name) -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22)) = do { fix2 <- lookupTyFixityRn op2 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (\t1 t2 -> HsOpTy t1 op2 t2) + (\t1 t2 -> HsOpTy t1 (w2, op2) t2) (unLoc op2) fix2 ty21 ty22 loc2 } mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22)) diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index 9af757c1af..7e3b44c7d5 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -78,7 +78,8 @@ import Literal ( litIsTrivial ) import Demand ( StrictSig, increaseStrictSigArity ) import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString ) -import Type ( isUnLiftedType, Type ) +import Type ( isUnLiftedType, Type, sortQuantVars ) +import Kind ( kiVarsOfKinds ) import BasicTypes ( Arity ) import UniqSupply import Util @@ -996,22 +997,13 @@ abstractVars :: Level -> LevelEnv -> VarSet -> [Var] -- whose level is greater than the destination level -- These are the ones we are going to abstract out abstractVars dest_lvl (LE { le_lvl_env = lvl_env, le_env = id_env }) fvs - = map zap $ uniq $ sortLe le + = map zap $ uniq $ sortQuantVars -- IA0_NOTE: centralizing sorting on variables [var | fv <- varSetElems fvs , var <- absVarsOf id_env fv , abstract_me var ] -- NB: it's important to call abstract_me only on the OutIds the -- come from absVarsOf (not on fv, which is an InId) where - -- Sort the variables so the true type variables come first; - -- the tyvars scope over Ids and coercion vars - v1 `le` v2 = case (is_tv v1, is_tv v2) of - (True, False) -> True - (False, True) -> False - _ -> v1 <= v2 -- Same family - - is_tv v = isTyVar v - uniq :: [Var] -> [Var] -- Remove adjacent duplicates; the sort will have brought them together uniq (v1:v2:vs) | v1 == v2 = uniq (v2:vs) @@ -1036,7 +1028,9 @@ absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var] -- variables -- -- Also, if x::a is an abstracted variable, then so is a; that is, - -- we must look in x's type + -- we must look in x's type. What's more, if a mentions kind variables, + -- we must also return those. + -- -- And similarly if x is a coercion variable. absVarsOf id_env v | isId v = [av2 | av1 <- lookup_avs v @@ -1047,7 +1041,9 @@ absVarsOf id_env v Just (abs_vars, _) -> abs_vars Nothing -> [v] - add_tyvars v = v : varSetElems (varTypeTyVars v) + add_tyvars v = v : (varSetElems tyvars ++ varSetElems kivars) + tyvars = varTypeTyVars v + kivars = kiVarsOfKinds (map tyVarKind (varSetElems tyvars)) \end{code} \begin{code} diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 1fc8a58cdb..6a0820c4e4 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -1383,7 +1383,7 @@ abstractFloats main_tvs body_env body ; return (subst', (NonRec poly_id poly_rhs)) } where rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs - tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs') + tvs_here = varSetElemsKvsFirst (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs') -- Abstract only over the type variables free in the rhs -- wrt which the new binding is abstracted. But the naive @@ -1422,7 +1422,7 @@ abstractFloats main_tvs body_env body -- If you ever want to be more selective, remember this bizarre case too: -- x::a = x -- Here, we must abstract 'x' over 'a'. - tvs_here = main_tvs + tvs_here = sortQuantVars main_tvs mk_poly tvs_here var = do { uniq <- getUniqueM @@ -1745,18 +1745,21 @@ mkCase dflags scrut bndr alts = mkCase1 dflags scrut bndr alts mkCase1 _dflags scrut case_bndr alts -- Identity case | all identity_alt alts = do { tick (CaseIdentity case_bndr) - ; return (re_cast scrut) } + ; return (re_cast scrut rhs1) } where - identity_alt (con, args, rhs) = check_eq con args (de_cast rhs) + identity_alt (con, args, rhs) = check_eq con args rhs - check_eq DEFAULT _ (Var v) = v == case_bndr - check_eq (LitAlt lit') _ (Lit lit) = lit == lit' - check_eq (DataAlt con) args rhs = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args) - || rhs `cheapEqExpr` Var case_bndr - check_eq _ _ _ = False + check_eq con args (Cast e co) | not (any (`elemVarSet` tyCoVarsOfCo co) args) + {- See Note [RHS casts] -} = check_eq con args e + check_eq _ _ (Var v) = v == case_bndr + check_eq (LitAlt lit') _ (Lit lit) = lit == lit' + check_eq (DataAlt con) args rhs = rhs `cheapEqExpr` mkConApp con (arg_tys ++ varsToCoreExprs args) + check_eq _ _ _ = False arg_tys = map Type (tyConAppArgs (idType case_bndr)) + -- Note [RHS casts] + -- ~~~~~~~~~~~~~~~~ -- We've seen this: -- case e of x { _ -> x `cast` c } -- And we definitely want to eliminate this case, to give @@ -1766,12 +1769,11 @@ mkCase1 _dflags scrut case_bndr alts -- Identity case -- if (all identity_alt alts) holds. -- -- Don't worry about nested casts, because the simplifier combines them - de_cast (Cast e _) = e - de_cast e = e - re_cast scrut = case head alts of - (_,_,Cast _ co) -> Cast scrut co - _ -> scrut + ((_,_,rhs1):_) = alts + + re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co + re_cast scrut _ = scrut -------------------------------------------------- -- 3. Merge Identical Alternatives diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 1f60781fec..6f811a91e6 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -987,8 +987,13 @@ simplCoercionF env co cont simpl_co co (CoerceIt g cont) = simpl_co new_co cont where - new_co = mkSymCo g0 `mkTransCo` co `mkTransCo` g1 - [g0, g1] = decomposeCo 2 g + -- g :: (s1 ~# s2) ~# (t1 ~# t2) + -- g1 :: s1 ~# t1 + -- g2 :: s2 ~# t2 + new_co = mkSymCo g1 `mkTransCo` co `mkTransCo` g2 + [_reflk, g1, g2] = decomposeCo 3 g + -- Remember, (~#) :: forall k. k -> k -> * + -- so it takes *three* arguments, not two simpl_co co cont = seqCo co `seq` rebuild env (Coercion co) cont diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 97ba4e8ab7..0a94b2b5a7 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -255,6 +255,7 @@ addLocalFamInst home_fie famInst = do -- If there are any conflicts, we should probably error -- But, if we're allowed to overwrite and the conflict is in the home FIE, -- then overwrite instead of error. + traceTc "checkForConflicts" (ppr conflicts $$ ppr famInst $$ ppr inst_envs) isGHCi <- getIsGHCi case conflicts of dup : _ -> case (isGHCi, home_conflicts) of diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 62690a50bd..e6943ea4ca 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -287,9 +287,14 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) -- Check that it has the right shape: -- ((w,s1) .. sn) -- where the si do not mention w - ; checkTc (corner_ty `eqType` mkTyVarTy w_tv && - not (w_tv `elemVarSet` tyVarsOfTypes arg_tys)) + ; _bogus <- unifyType corner_ty (mkTyVarTy w_tv) + ; checkTc (not (w_tv `elemVarSet` tyVarsOfTypes arg_tys)) (badFormFun i tup_ty') + -- JPM: WARNING: this test is utterly bogus; see #5609 + -- We are not using the coercion returned by the unify; + -- and (even more seriously) the w not in arg_tys test is totally + -- bogus if there are suspended equality constraints. This code + -- needs to be re-architected. ; tcCmdTop (env { cmd_arr = b }) cmd arg_tys s } diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index ac2fe8c11b..f12bad426d 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -1273,6 +1273,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn ATyVar {} -> False -- In-scope type variables AGlobal {} -> True -- are not closed! AThing {} -> pprPanic "is_closed_id" (ppr name) + ANothing {} -> pprPanic "is_closed_id" (ppr name) | otherwise = WARN( isInternalName name, ppr name ) True -- The free-var set for a top level binding mentions diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 83497a8f4c..8cec0b564d 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -21,6 +21,7 @@ import FunDeps import qualified TcMType as TcM import TcType import Type +import Kind import Coercion import Class import TyCon @@ -474,28 +475,32 @@ canEq fl eqv ty1 (TyConApp fn tys) = do { untch <- getUntouchables ; canEqLeaf untch fl eqv (classify ty1) (FunCls fn tys) } -canEq fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2) +canEq fl eqv ty1@(TyConApp tc1 tys1) ty2@(TyConApp tc2 tys2) | isDecomposableTyCon tc1 && isDecomposableTyCon tc2 , tc1 == tc2 , length tys1 == length tys2 = -- Generate equalities for each of the corresponding arguments - do { argeqvs + do { let (kis1, tys1') = span isKind tys1 + (kis2, tys2') = span isKind tys2 + ; zipWithM_ (unifyKindTcS ty1 ty2) kis1 kis2 + ; let kicos = map mkReflCo kis1 + ; argeqvs <- if isWanted fl then - do { argeqvs <- zipWithM newEqVar tys1 tys2 + do { argeqvs <- zipWithM newEqVar tys1' tys2' ; setEqBind eqv - (mkTyConAppCo tc1 (map mkEqVarLCo argeqvs)) + (mkTyConAppCo tc1 (kicos ++ (map mkEqVarLCo argeqvs))) ; return argeqvs } else if isGivenOrSolved fl then let go_one ty1 ty2 n = do argeqv <- newEqVar ty1 ty2 setEqBind argeqv (mkNthCo n (mkEqVarLCo eqv)) return argeqv - in zipWith3M go_one tys1 tys2 [0..] + in zipWith3M go_one tys1' tys2' [(length kicos)..] else -- Derived - zipWithM (\t1 t2 -> newDerivedId (mkEqPred (t1, t2))) tys1 tys2 + zipWithM (\t1 t2 -> newDerivedId (mkEqPred (t1, t2))) tys1' tys2' - ; andCCans <$> zipWith3M (canEq fl) argeqvs tys1 tys2 } + ; andCCans <$> zipWith3M (canEq fl) argeqvs tys1' tys2' } -- See Note [Equality between type applications] -- Note [Care with type applications] in TcUnify @@ -504,7 +509,8 @@ canEq fl eqv ty1 ty2 , Nothing <- tcView ty2 -- See Note [Naked given applications] , Just (s1,t1) <- tcSplitAppTy_maybe ty1 , Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = if isWanted fl + = ASSERT( not (isKind t1) && not (isKind t2) ) + if isWanted fl then do { eqv1 <- newEqVar s1 s2 ; eqv2 <- newEqVar t1 t2 ; setEqBind eqv @@ -772,15 +778,10 @@ canEqLeafOriented :: CtFlavor -> EqVar -> TypeClassifier -> TcType -> TcS CanonicalCts -- First argument is not OtherCls canEqLeafOriented fl eqv cls1@(FunCls fn tys1) s2 -- cv : F tys1 - | let k1 = kindAppResult (tyConKind fn) tys1, - let k2 = typeKind s2, - not (k1 `compatKind` k2) -- Establish the kind invariant for CFunEqCan - = canEqFailure fl eqv - -- Eagerly fails, see Note [Kind errors] in TcInteract - - | otherwise = ASSERT2( isSynFamilyTyCon fn, ppr (unClassify cls1) ) - do { (xis1,cos1,ccs1) <- flattenMany fl tys1 -- Flatten type function arguments + do { are_compat <- compatKindTcS k1 k2 -- make sure that the kind are compatible + ; unless are_compat (unifyKindTcS (unClassify cls1) s2 k1 k2) + ; (xis1,cos1,ccs1) <- flattenMany fl tys1 -- Flatten type function arguments -- cos1 :: xis1 ~ tys1 ; (xi2, co2, ccs2) <- flatten fl s2 -- Flatten entire RHS -- co2 :: xi2 ~ s2 @@ -810,6 +811,10 @@ canEqLeafOriented fl eqv cls1@(FunCls fn tys1) s2 -- cv : F tys1 , cc_tyargs = xis1 , cc_rhs = xi2 } ; return $ ccs `extendCCans` final_cc } + where + k1 = typeKind (unClassify cls1) + k2 = typeKind s2 + -- Otherwise, we have a variable on the left, so call canEqLeafTyVarLeft canEqLeafOriented fl eqv (FskCls tv) s2 @@ -822,11 +827,9 @@ canEqLeafOriented _ eqv (OtherCls ty1) ty2 canEqLeafTyVarLeft :: CtFlavor -> EqVar -> TcTyVar -> TcType -> TcS CanonicalCts -- Establish invariants of CTyEqCans canEqLeafTyVarLeft fl eqv tv s2 -- cv : tv ~ s2 - | not (k1 `compatKind` k2) -- Establish the kind invariant for CTyEqCan - = canEqFailure fl eqv - -- Eagerly fails, see Note [Kind errors] in TcInteract - | otherwise - = do { (xi2, co, ccs2) <- flatten fl s2 -- Flatten RHS co : xi2 ~ s2 + = do { are_compat <- compatKindTcS k1 k2 + ; unless are_compat (unifyKindTcS (mkTyVarTy tv) s2 k1 k2) + ; (xi2, co, ccs2) <- flatten fl s2 -- Flatten RHS co : xi2 ~ s2 ; mxi2' <- canOccursCheck fl tv xi2 -- Do an occurs check, and return a possibly -- unfolded version of the RHS, if we had to -- unfold any type synonyms to get rid of tv. @@ -1041,7 +1044,7 @@ instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,(EvVar,WantedLoc))] instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs , fd_pred1 = d1, fd_pred2 = d2 }) = do { let tvs = varSetElems qtvs - ; tvs' <- mapM instFlexiTcS tvs + ; tvs' <- mapM instFlexiTcS tvs -- IA0_TODO: we might need to do kind substitution ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs') ; foldM (do_one subst) [] eqs } where diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index ab938d368a..68f27148b6 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -119,7 +119,7 @@ tcClassSigs clas sigs def_methods dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] tc_sig genop_env (op_names, op_hs_ty) - = do { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope + = do { op_ty <- tcHsType op_hs_ty -- Class tyvars already in scope ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] } where f nm | nm `elemNameEnv` genop_env = GenericDM @@ -127,7 +127,7 @@ tcClassSigs clas sigs def_methods | otherwise = NoDM tc_gen_sig (op_names, gen_hs_ty) - = do { gen_op_ty <- tcHsKindedType gen_hs_ty + = do { gen_op_ty <- tcHsType gen_hs_ty ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] } \end{code} diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index a5c55263a3..db25c134d7 100755 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -34,7 +34,7 @@ import TcMType import TcSimplify import RnBinds -import RnEnv +import RnEnv import RnSource ( addTcgDUs ) import HscTypes @@ -474,13 +474,12 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) = setSrcSpan loc $ addErrCtxt (standaloneCtxt deriv_ty) $ do { traceTc "Standalone deriving decl for" (ppr deriv_ty) - ; (tvs, theta, cls, inst_tys) <- tcHsInstHead deriv_ty + ; (tvs, theta, cls, inst_tys) <- tcHsInstHead TcType.InstDeclCtxt deriv_ty ; traceTc "Standalone deriving;" $ vcat [ text "tvs:" <+> ppr tvs , text "theta:" <+> ppr theta , text "cls:" <+> ppr cls , text "tys:" <+> ppr inst_tys ] - ; checkValidInstance deriv_ty tvs theta cls inst_tys -- C.f. TcInstDcls.tcLocalInstDecl1 ; let cls_tys = take (length inst_tys - 1) inst_tys @@ -494,6 +493,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) ------------------------------------------------------------------ deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec +-- The deriving clause of a data or newtype declaration deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, tcdTyVars = tv_names, tcdTyPats = ty_pats })) @@ -541,7 +541,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0) (typeFamilyPapErr tc cls cls_tys inst_ty) - ; mkEqnHelp DerivOrigin (varSetElems univ_tvs) cls cls_tys inst_ty Nothing } } + ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } } where -- Tiresomely we must figure out the "lhs", which is awkward for type families -- E.g. data T a b = .. deriving( Eq ) @@ -553,6 +553,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, get_lhs Nothing = do { tc <- tcLookupTyCon tycon_name ; let tvs = tyConTyVars tc ; return (tvs, tc, mkTyVarTys tvs) } + -- JPM: to fix get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app ; let (tc, tc_args) = tcSplitTyConApp tc_app @@ -1111,7 +1112,7 @@ mkNewTypeEqn orig dflags tvs ; dfun_name <- new_dfun_name cls tycon ; loc <- getSrcSpanM ; let spec = DS { ds_loc = loc, ds_orig = orig - , ds_name = dfun_name, ds_tvs = varSetElems dfun_tvs + , ds_name = dfun_name, ds_tvs = varSetElemsKvsFirst dfun_tvs , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = mtheta `orElse` all_preds diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 48b637bdd8..4fe7ee1b93 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -14,13 +14,13 @@ module TcEnv( -- Global environment tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv, tcExtendGlobalValEnv, - tcLookupLocatedGlobal, tcLookupGlobal, + tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedClass, tcLookupInstance, -- Local environment - tcExtendKindEnv, tcExtendKindEnvTvs, + tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTcTyThingEnv, tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendGhciEnv, tcExtendLetEnv, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, @@ -32,13 +32,13 @@ module TcEnv( tcExtendRecEnv, -- For knot-tying -- Rules - tcExtendRules, + tcExtendRules, -- Defaults tcGetDefaultTys, -- Global type variables - tcGetGlobalTyVars, + tcGetGlobalTyVars, zapLclTypeEnv, -- Template Haskell stuff checkWellStaged, tcMetaTy, thLevel, @@ -221,36 +221,31 @@ setGlobalTypeEnv tcg_env new_type_env ; return (tcg_env { tcg_type_env = new_type_env }) } -tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r - -- Given a mixture of Ids, TyCons, Classes, all defined in the - -- module being compiled, extend the global environment -tcExtendGlobalEnv things thing_inside - = do { env <- getGblEnv - ; let env' = env { tcg_tcs = [ tc | ATyCon tc <- things, - not (isClassTyCon tc)] - ++ tcg_tcs env - , tcg_clss = [ cl | ATyCon tc <- things, - Just cl <- [tyConClass_maybe tc]] - ++ tcg_clss env } - ; setGblEnv env' $ - tcExtendGlobalEnvImplicit things thing_inside - } - tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r -- Extend the global environment with some TyThings that can be obtained -- via implicitTyThings from other entities in the environment. Examples -- are dfuns, famInstTyCons, data cons, etc. - -- These TyThings are not added to tcg_tcs or tcg_clss. + -- These TyThings are not added to tcg_tcs. tcExtendGlobalEnvImplicit things thing_inside = do { tcg_env <- getGblEnv ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things ; tcg_env' <- setGlobalTypeEnv tcg_env ge' ; setGblEnv tcg_env' thing_inside } +tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r + -- Given a mixture of Ids, TyCons, Classes, all defined in the + -- module being compiled, extend the global environment +tcExtendGlobalEnv things thing_inside + = do { env <- getGblEnv + ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env } + ; setGblEnv env' $ + tcExtendGlobalEnvImplicit things thing_inside + } + tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a -- Same deal as tcExtendGlobalEnv, but for Ids tcExtendGlobalValEnv ids thing_inside - = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside + = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r -- Extend the global environments for the type/class knot tying game @@ -319,6 +314,13 @@ getInLocalScope = do { lcl_env <- getLclTypeEnv \end{code} \begin{code} +tcExtendTcTyThingEnv :: [(Name, TcTyThing)] -> TcM r -> TcM r +tcExtendTcTyThingEnv things thing_inside + = updLclEnv upd thing_inside + where + upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } + extend env = extendNameEnvList env things + tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r tcExtendKindEnv things thing_inside = updLclEnv upd thing_inside @@ -442,6 +444,14 @@ tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet) tcExtendGlobalTyVars gtv_var extra_global_tvs = do { global_tvs <- readMutVar gtv_var ; newMutVar (global_tvs `unionVarSet` extra_global_tvs) } + +zapLclTypeEnv :: TcM a -> TcM a +zapLclTypeEnv thing_inside + = do { tvs_var <- newTcRef emptyVarSet + ; let upd env = env { tcl_env = emptyNameEnv + , tcl_rdr = emptyLocalRdrEnv + , tcl_tyvars = tvs_var } + ; updLclEnv upd thing_inside } \end{code} @@ -724,11 +734,15 @@ pprBinders bndrs = pprWithCommas ppr bndrs notFound :: Name -> TcM TyThing notFound name - = do { (gbl,lcl) <- getEnvs + = do { (_gbl,lcl) <- getEnvs ; failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> ptext (sLit "is not in scope during type checking, but it passed the renamer"), - ptext (sLit "tcg_type_env of environment:") <+> ppr (tcg_type_env gbl), ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl)] + -- Take case: printing the whole gbl env can + -- cause an infnite loop, in the case where we + -- are in the middle of a recursive TyCon/Class group; + -- so let's just not print it! Getting a loop here is + -- very unhelpful, because it hides one compiler bug with another ) } wrongThingErr :: String -> TcTyThing -> Name -> TcM a diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 1835956f3a..52177567e3 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -45,6 +45,7 @@ import DataCon import Name import TyCon import Type +import Kind( splitKiTyVars ) import Coercion import Var import VarSet @@ -290,8 +291,8 @@ tcExpr (OpApp arg1 op fix arg2) res_ty -- Make sure that the argument and result types have kind '*' -- Eg we do not want to allow (D# $ 4.0#) Trac #5570 - ; unifyKind (typeKind arg2_ty) liftedTypeKind - ; unifyKind (typeKind res_ty) liftedTypeKind + ; _ <- unifyKind (typeKind arg2_ty) liftedTypeKind + ; _ <- unifyKind (typeKind res_ty) liftedTypeKind ; arg2' <- tcArg op (arg2, arg2_ty, 2) ; co_res <- unifyType op_res_ty res_ty @@ -646,16 +647,24 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty -- ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons is_fixed_tv tv = tv `elemVarSet` fixed_tvs - mk_inst_ty tv result_inst_ty + mk_inst_ty subst tv result_inst_ty | is_fixed_tv tv = return result_inst_ty -- Same as result type - | otherwise = newFlexiTyVarTy (tyVarKind tv) -- Fresh type, of correct kind + | otherwise = newFlexiTyVarTy (subst (tyVarKind tv)) -- Fresh type, of correct kind ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs - ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys - ; let rec_res_ty = TcType.substTy result_inst_env con1_res_ty + ; let (con1_r_kvs, con1_r_tvs) = splitKiTyVars con1_tvs + n_kinds = length con1_r_kvs + (result_inst_r_kis, result_inst_r_tys) = splitAt n_kinds result_inst_tys + ; scrut_inst_r_kis <- zipWithM (mk_inst_ty (TcType.substTy (zipTopTvSubst [] []))) con1_r_kvs result_inst_r_kis + -- IA0_NOTE: we have to build the kind substitution + ; let kind_subst = TcType.substTy (zipTopTvSubst con1_r_kvs scrut_inst_r_kis) + ; scrut_inst_r_tys <- zipWithM (mk_inst_ty kind_subst) con1_r_tvs result_inst_r_tys + + ; let scrut_inst_tys = scrut_inst_r_kis ++ scrut_inst_r_tys + rec_res_ty = TcType.substTy result_inst_env con1_res_ty con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys - scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys + scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys scrut_ty = TcType.substTy scrut_subst con1_res_ty ; co_res <- unifyType rec_res_ty res_ty diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index e50d41bd13..e1ab27c3b2 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -26,7 +26,7 @@ module TcHsSyn ( -- re-exported from TcMonad TcId, TcIdSet, - zonkTopDecls, zonkTopExpr, zonkTopLExpr, + zonkTopDecls, zonkTopExpr, zonkTopLExpr, mkZonkTcTyVar, zonkId, zonkTopBndrs ) where @@ -45,6 +45,8 @@ import TcMType import Coercion import TysPrim import TysWiredIn +import Type +import Kind import DataCon import Name import NameSet @@ -189,8 +191,15 @@ It's all pretty boring stuff, because HsSyn is such a large type, and the environment manipulation is tiresome. \begin{code} -data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type - (VarEnv Var) -- What variables are in scope +type UnboundTyVarZonker = TcTyVar-> TcM Type + -- How to zonk an unbound type variable + -- Note [Zonking the LHS of a RULE] + +data ZonkEnv + = ZonkEnv + UnboundTyVarZonker + (TyVarEnv TyVar) -- + (IdEnv Var) -- What variables are in scope -- Maps an Id or EvVar to its zonked version; both have the same Name -- Note that all evidence (coercion variables as well as dictionaries) -- are kept in the ZonkEnv @@ -198,21 +207,25 @@ data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type -- Is only consulted lazily; hence knot-tying emptyZonkEnv :: ZonkEnv -emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv +emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv emptyVarEnv -extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv -extendZonkEnv (ZonkEnv zonk_ty env) ids - = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids]) +extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv +extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids + = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids]) -extendZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv -extendZonkEnv1 (ZonkEnv zonk_ty env) id - = ZonkEnv zonk_ty (extendVarEnv env id id) +extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv +extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id + = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id) -setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv -setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env +extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv +extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty + = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env + +setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv +setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env zonkEnvIds :: ZonkEnv -> [Id] -zonkEnvIds (ZonkEnv _ env) = varEnvElts env +zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env zonkIdOcc :: ZonkEnv -> TcId -> Id -- Ids defined in this module should be in the envt; @@ -230,7 +243,7 @@ zonkIdOcc :: ZonkEnv -> TcId -> Id -- -- Even without template splices, in module Main, the checking of -- 'main' is done as a separate chunk. -zonkIdOcc (ZonkEnv _zonk_ty env) id +zonkIdOcc (ZonkEnv _zonk_ty _ty_env env) id | isLocalVar id = lookupVarEnv env id `orElse` id | otherwise = id @@ -257,17 +270,30 @@ zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar) -- Works for dictionaries and coercions zonkEvBndrX env var = do { var' <- zonkEvBndr env var - ; return (extendZonkEnv1 env var', var') } + ; return (extendIdZonkEnv1 env var', var') } zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar -- Works for dictionaries and coercions -- Does not extend the ZonkEnv zonkEvBndr env var - = do { ty' <- zonkTcTypeToType env (varType var) - ; return (setVarType var ty') } + = do { ty <- zonkTcTypeToType env (varType var) + ; return (setVarType var ty) } zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar zonkEvVarOcc env v = zonkIdOcc env v + +zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar]) +zonkTyBndrsX = mapAccumLM zonkTyBndrX + +zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar) +zonkTyBndrX env tv + = do { tv' <- zonkTyBndr env tv + ; return (extendTyZonkEnv1 env tv', tv') } + +zonkTyBndr :: ZonkEnv -> TyVar -> TcM TyVar +zonkTyBndr env tv + = do { ki <- zonkTcTypeToType env (tyVarKind tv) + ; return (setVarType tv ki) } \end{code} @@ -331,7 +357,7 @@ zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs)) zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds -> let - env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds] + env1 = extendIdZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds] in zonkTcEvBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) -> returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds)) @@ -345,7 +371,7 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id) zonkRecMonoBinds env sig_warn binds = fixM (\ ~(_, new_binds) -> do - { let env1 = extendZonkEnv env (collectHsBindsBinders new_binds) + { let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds) ; binds' <- zonkMonoBinds env1 sig_warn binds ; return (env1, binds') }) @@ -425,15 +451,17 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , abs_exports = exports , abs_binds = val_binds }) = ASSERT( all isImmutableTyVar tyvars ) - do { (env1, new_evs) <- zonkEvBndrsX env evs + do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars + ; (env1, new_evs) <- zonkEvBndrsX env0 evs ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> - do { let env3 = extendZonkEnv env2 (collectHsBindsBinders new_val_binds) + do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds) ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds ; new_exports <- mapM (zonkExport env3) exports ; return (new_val_binds, new_exports) } ; sig_warn True (map abe_poly new_exports) - ; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds + ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs + , abs_ev_binds = new_ev_binds , abs_exports = new_exports, abs_binds = new_val_bind }) } where zonkExport env (ABE{ abe_wrap = wrap, abe_poly = poly_id @@ -695,7 +723,8 @@ zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg ; return (env, WpEvApp arg') } zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) - return (env, WpTyLam tv) + do { (env', tv') <- zonkTyBndrX env tv + ; return (env', WpTyLam tv') } zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty ; return (env, WpTyApp ty') } zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs @@ -744,7 +773,7 @@ zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op) = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs -> let new_binders = concat (map snd new_stmts_w_bndrs) - env1 = extendZonkEnv env new_binders + env1 = extendIdZonkEnv env new_binders in zonkExpr env1 mzip_op `thenM` \ new_mzip -> zonkExpr env1 bind_op `thenM` \ new_bind -> @@ -763,12 +792,12 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id ; new_ret_id <- zonkExpr env ret_id ; new_mfix_id <- zonkExpr env mfix_id ; new_bind_id <- zonkExpr env bind_id - ; let env1 = extendZonkEnv env new_rvs + ; let env1 = extendIdZonkEnv env new_rvs ; (env2, new_segStmts) <- zonkStmts env1 segStmts -- Zonk the ret-expressions in an envt that -- has the polymorphic bindings in the envt ; new_rets <- mapM (zonkExpr env2) rets - ; return (extendZonkEnv env new_lvs, -- Only the lvs are needed + ; return (extendIdZonkEnv env new_lvs, -- Only the lvs are needed RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id @@ -796,7 +825,7 @@ zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap ; return_op' <- zonkExpr env' return_op ; bind_op' <- zonkExpr env' bind_op ; liftM_op' <- zonkExpr env' liftM_op - ; let env'' = extendZonkEnv env' (map snd binderMap') + ; let env'' = extendIdZonkEnv env' (map snd binderMap') ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' , trS_by = by', trS_form = form, trS_using = using' , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) } @@ -858,7 +887,7 @@ zonk_pat env (WildPat ty) zonk_pat env (VarPat v) = do { v' <- zonkIdBndr env v - ; return (extendZonkEnv1 env v', VarPat v') } + ; return (extendIdZonkEnv1 env v', VarPat v') } zonk_pat env (LazyPat pat) = do { (env', pat') <- zonkPat env pat @@ -870,7 +899,7 @@ zonk_pat env (BangPat pat) zonk_pat env (AsPat (L loc v) pat) = do { v' <- zonkIdBndr env v - ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat + ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat ; return (env', AsPat (L loc v') pat') } zonk_pat env (ViewPat expr pat ty) @@ -921,7 +950,7 @@ zonk_pat env (NPlusKPat (L loc n) lit e1 e2) ; lit' <- zonkOverLit env lit ; e1' <- zonkExpr env e1 ; e2' <- zonkExpr env e2 - ; return (extendZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') } + ; return (extendIdZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') } zonk_pat env (CoPat co_fn pat ty) = do { (env', co_fn') <- zonkCoFn env co_fn @@ -983,35 +1012,21 @@ zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id) zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) - = do { (env_rhs, new_bndrs) <- mapAccumLM zonk_bndr env vars - - ; unbound_tv_set <- newMutVar emptyVarSet - ; let env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set) - -- We need to gather the type variables mentioned on the LHS so we can - -- quantify over them. Example: - -- data T a = C - -- - -- foo :: T a -> Int - -- foo C = 1 - -- - -- {-# RULES "myrule" foo C = 1 #-} - -- - -- After type checking the LHS becomes (foo a (C a)) - -- and we do not want to zap the unbound tyvar 'a' to (), because - -- that limits the applicability of the rule. Instead, we - -- want to quantify over it! - -- - -- It's easiest to find the free tyvars here. Attempts to do so earlier - -- are tiresome, because (a) the data type is big and (b) finding the - -- free type vars of an expression is necessarily monadic operation. - -- (consider /\a -> f @ b, where b is side-effected to a) - - ; new_lhs <- zonkLExpr env_lhs lhs - ; new_rhs <- zonkLExpr env_rhs rhs - - ; unbound_tvs <- readMutVar unbound_tv_set + = do { unbound_tkv_set <- newMutVar emptyVarSet + ; let env_rule = setZonkType env (zonkTvCollecting unbound_tkv_set) + -- See Note [Zonking the LHS of a RULE] + + ; (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env_rule vars + + ; new_lhs <- zonkLExpr env_inside lhs + ; new_rhs <- zonkLExpr env_inside rhs + + ; unbound_tkvs <- readMutVar unbound_tkv_set + ; let final_bndrs :: [RuleBndr Var] - final_bndrs = map (RuleBndr . noLoc) (varSetElems unbound_tvs) ++ new_bndrs + final_bndrs = map (RuleBndr . noLoc) + (varSetElemsKvsFirst unbound_tkvs) + ++ new_bndrs ; return (HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs) } where @@ -1020,7 +1035,7 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig" zonk_it env v - | isId v = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') } + | isId v = do { v' <- zonkIdBndr env v; return (extendIdZonkEnv1 env v', v') } | otherwise = ASSERT( isImmutableTyVar v) return (env, v) \end{code} @@ -1085,7 +1100,7 @@ zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind) zonkEvBinds env binds = fixM (\ ~( _, new_binds) -> do - { let env1 = extendZonkEnv env (collect_ev_bndrs new_binds) + { let env1 = extendIdZonkEnv env (collect_ev_bndrs new_binds) ; binds' <- mapBagM (zonkEvBind env1) binds ; return (env1, binds') }) where @@ -1106,39 +1121,108 @@ zonkEvBind env (EvBind var term) %* * %************************************************************************ +Note [Zonking the LHS of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to gather the type variables mentioned on the LHS so we can +quantify over them. Example: + data T a = C + + foo :: T a -> Int + foo C = 1 + + {-# RULES "myrule" foo C = 1 #-} + +After type checking the LHS becomes (foo a (C a)) +and we do not want to zap the unbound tyvar 'a' to (), because +that limits the applicability of the rule. Instead, we +want to quantify over it! + +It's easiest to get zonkTvCollecting to gather the free tyvars +here. Attempts to do so earlier are tiresome, because (a) the data +type is big and (b) finding the free type vars of an expression is +necessarily monadic operation. (consider /\a -> f @ b, where b is +side-effected to a) + +And that in turn is why ZonkEnv carries the function to use for +type variables! + +Note [Zonking mutable unbound type or kind variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In zonkTypeZapping, we zonk mutable but unbound type or kind variables to an +arbitrary type. We know if they are unbound even though we don't carry an +environment, because at the binding site for a variable we bind the mutable +var to a fresh immutable one. So the mutable store plays the role of an +environment. If we come across a mutable variable that isn't so bound, it +must be completely free. We zonk the expected kind to make sure we don't get +some unbound meta variable as the kind. + +Note that since we have kind polymorphism, zonk_unbound_tyvar will handle both +type and kind variables. Consider the following datatype: + + data Phantom a = Phantom Int + +The type of Phantom is (forall (k : BOX). forall (a : k). Int). Both `a` and +`k` are unbound variables. We want to zonk this to +(forall (k : AnyK). forall (a : Any AnyK). Int). For that we have to check if +we have a type or a kind variable; for kind variables we just return AnyK (and +not the ill-kinded Any BOX). + \begin{code} +mkZonkTcTyVar :: (TcTyVar -> TcM Type) -- What to do for an *mutable Flexi* var + -> (TcTyVar -> Type) -- What to do for an immutable var + -> TcTyVar -> TcM TcType +mkZonkTcTyVar unbound_mvar_fn unbound_ivar_fn + = zonk_tv + where + zonk_tv tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + SkolemTv {} -> return (unbound_ivar_fn tv) + RuntimeUnk {} -> return (unbound_ivar_fn tv) + FlatSkol ty -> zonkType zonk_tv ty + MetaTv _ ref -> do { cts <- readMutVar ref + ; case cts of + Flexi -> do { kind <- zonkType zonk_tv (tyVarKind tv) + ; unbound_mvar_fn (setTyVarKind tv kind) } + Indirect ty -> zonkType zonk_tv ty } + zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type -zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty +zonkTcTypeToType (ZonkEnv zonk_unbound_tyvar tv_env _id_env) + = zonkType (mkZonkTcTyVar zonk_unbound_tyvar zonk_bound_tyvar) + where + zonk_bound_tyvar tv = case lookupVarEnv tv_env tv of + Nothing -> mkTyVarTy tv + Just tv' -> mkTyVarTy tv' zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type] zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys -zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type +zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker -- This variant collects unbound type variables in a mutable variable -zonkTypeCollecting unbound_tv_set - = zonkType (mkZonkTcTyVar zonk_unbound_tyvar) - where - zonk_unbound_tyvar tv - = do { tv' <- zonkQuantifiedTyVar tv - ; tv_set <- readMutVar unbound_tv_set - ; writeMutVar unbound_tv_set (extendVarSet tv_set tv') - ; return (mkTyVarTy tv') } - -zonkTypeZapping :: TcType -> TcM Type +-- Works on both types and kinds +zonkTvCollecting unbound_tv_set tv + = do { poly_kinds <- xoptM Opt_PolyKinds + ; if isKiVar tv && not poly_kinds then + do { defaultKindVarToStar tv + ; return liftedTypeKind } + else do + { tv' <- zonkQuantifiedTyVar tv + ; tv_set <- readMutVar unbound_tv_set + ; writeMutVar unbound_tv_set (extendVarSet tv_set tv') + ; return (mkTyVarTy tv') } } + +zonkTypeZapping :: UnboundTyVarZonker -- This variant is used for everything except the LHS of rules -- It zaps unbound type variables to (), or some other arbitrary type -zonkTypeZapping ty - = zonkType (mkZonkTcTyVar zonk_unbound_tyvar) ty - where - -- Zonk a mutable but unbound type variable to an arbitrary type - -- We know it's unbound even though we don't carry an environment, - -- because at the binding site for a type variable we bind the - -- mutable tyvar to a fresh immutable one. So the mutable store - -- plays the role of an environment. If we come across a mutable - -- type variable that isn't so bound, it must be completely free. - zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv) - ; writeMetaTyVar tv ty - ; return ty } +-- Works on both types and kinds +zonkTypeZapping tv + = do { let ty = if isKiVar tv + -- ty is actually a kind, zonk to AnyK + then anyKind + else anyTypeOfKind (tyVarKind tv) + ; writeMetaTyVar tv ty + ; return ty } + zonkTcLCoToLCo :: ZonkEnv -> LCoercion -> TcM LCoercion zonkTcLCoToLCo env co diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index b0ef207799..8f1fb54df3 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -20,11 +20,16 @@ module TcHsType ( -- Kind checking kcHsTyVars, kcHsSigType, kcHsLiftedSigType, kcLHsType, kcCheckLHsType, kcHsContext, kcApps, - - -- Typechecking kinded types - tcHsKindedContext, tcHsKindedType, tcHsBangType, - tcTyVarBndrs, dsHsType, - tcDataKindSig, + kindGeneralizeKind, kindGeneralizeKinds, + + -- Sort checking + scDsLHsKind, scDsLHsMaybeKind, + + -- Typechecking kinded types + tcHsType, tcCheckHsType, + tcHsKindedContext, tcHsKindedType, tcHsBangType, + tcTyVarBndrs, tcTyVarBndrsKindGen, dsHsType, + tcDataKindSig, tcTyClTyVars, ExpKind(..), EkCtxt(..), ekConstraint, checkExpectedKind, @@ -42,27 +47,34 @@ import {-# SOURCE #-} TcSplice( kcSpliceType ) import HsSyn import RnHsSyn import TcRnMonad +import RnEnv ( polyKindsErr ) +import TcHsSyn ( mkZonkTcTyVar ) import TcEnv import TcMType import TcUnify import TcIface import TcType import {- Kind parts of -} Type -import Kind ( isConstraintKind ) +import Kind import Var import VarSet import TyCon +import DataCon ( DataCon, dataConUserType ) +import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName ) import Class +import RdrName ( rdrNameSpace, nameRdrName ) import Name import NameSet import TysWiredIn import BasicTypes import SrcLoc -import DynFlags ( ExtensionFlag( Opt_ConstraintKinds ) ) +import DynFlags ( ExtensionFlag( Opt_ConstraintKinds, Opt_PolyKinds ) ) import Util import UniqSupply import Outputable +import BuildTyCl ( buildPromotedDataTyCon ) import FastString +import Control.Monad ( unless ) \end{code} @@ -163,34 +175,37 @@ tcHsSigTypeNC ctxt hs_ty -- The kind is checked by checkValidType, and isn't necessarily -- of kind * in a Template Haskell quote eg [t| Maybe |] ; ty <- tcHsKindedType kinded_ty - ; checkValidType ctxt ty + ; checkValidType ctxt ty ; return ty } -tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type]) +-- Like tcHsType, but takes an expected kind +tcCheckHsType :: LHsType Name -> Kind -> TcM Type +tcCheckHsType hs_ty exp_kind + = do { kinded_ty <- kcCheckLHsType hs_ty (EK exp_kind EkUnk) -- JPM add context + ; ty <- tcHsKindedType kinded_ty + ; return ty } + +tcHsType :: LHsType Name -> TcM Type +-- kind check and desugar +-- no validity checking because of knot-tying +tcHsType hs_ty + = do { (kinded_ty, _) <- kc_lhs_type hs_ty + ; ty <- tcHsKindedType kinded_ty + ; return ty } + +tcHsInstHead :: UserTypeCtxt -> LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type]) -- Typecheck an instance head. We can't use -- tcHsSigType, because it's not a valid user type. -tcHsInstHead (L loc hs_ty) +tcHsInstHead ctxt lhs_ty@(L loc hs_ty) = setSrcSpan loc $ -- No need for an "In the type..." context -- because that comes from the caller - kc_ds_inst_head hs_ty - where - kc_ds_inst_head ty = case splitHsClassTy_maybe cls_ty of - Just _ -> do -- Kind-checking first - (tvs, ctxt, cls_ty) <- kcHsTyVars tv_names $ \ tv_names' -> do - ctxt' <- mapM kcHsLPredType ctxt - cls_ty' <- kc_check_hs_type cls_ty ekConstraint - -- The body of a forall is usually lifted, but in an instance - -- head we only allow something of kind Constraint. - return (tv_names', ctxt', cls_ty') - -- Now desugar the kind-checked type - let Just (cls_name, tys) = splitHsClassTy_maybe cls_ty - tcTyVarBndrs tvs $ \ tvs' -> do - ctxt' <- dsHsTypes ctxt - clas <- tcLookupClass cls_name - tys' <- dsHsTypes tys - return (tvs', ctxt', clas, tys') - _ -> failWithTc (ptext (sLit "Malformed instance type")) - where (tv_names, ctxt, cls_ty) = splitHsForAllTy ty + do { kinded_ty <- kc_check_hs_type hs_ty ekConstraint + ; ty <- ds_type kinded_ty + ; let (tvs, theta, tau) = tcSplitSigmaTy ty + ; case getClassPredTys_maybe tau of + Nothing -> failWithTc (ptext (sLit "Malformed instance type")) + Just (clas,tys) -> do { checkValidInstance ctxt lhs_ty tvs theta clas tys + ; return (tvs, theta, clas, tys) } } tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type) -- Behave very like type-checking (HsForAllTy sig_tvs hs_ty), @@ -219,7 +234,7 @@ tc_hs_deriv tv_names ty = kcHsTyVars tv_names $ \ tv_names' -> do { cls_kind <- kcClass cls_name ; (tys, _res_kind) <- kcApps cls_name cls_kind hs_tys - ; tcTyVarBndrs tv_names' $ \ tyvars -> + ; tcTyVarBndrsKindGen tv_names' $ \ tyvars -> do { arg_tys <- dsHsTypes tys ; cls <- tcLookupClass cls_name ; return (tyvars, cls, arg_tys) }} @@ -249,7 +264,7 @@ tcHsVectInst ty \begin{code} kcHsSigType, kcHsLiftedSigType :: LHsType Name -> TcM (LHsType Name) -- Used for type signatures -kcHsSigType ty = addKcTypeCtxt ty $ kcTypeType ty +kcHsSigType ty = addKcTypeCtxt ty $ kcArgType ty kcHsLiftedSigType ty = addKcTypeCtxt ty $ kcLiftedType ty tcHsKindedType :: LHsType Name -> TcM Type @@ -261,6 +276,7 @@ tcHsKindedType hs_ty = dsHsType hs_ty tcHsBangType :: LHsType Name -> TcM Type -- Permit a bang, but discard it +-- Input type has already been kind-checked tcHsBangType (L _ (HsBangTy _ ty)) = tcHsKindedType ty tcHsBangType ty = tcHsKindedType ty @@ -287,7 +303,7 @@ kcLiftedType ty = kc_check_lhs_type ty ekLifted --------------------------- kcTypeType :: LHsType Name -> TcM (LHsType Name) --- The type ty must be a *type*, but it can be lifted or +-- The type ty must be a *type*, but it can be lifted or -- unlifted or an unboxed tuple. kcTypeType ty = kc_check_lhs_type ty ekOpen @@ -297,6 +313,11 @@ kcArgs what tys kind | (ty,n) <- tys `zip` [1..] ] --------------------------- +kcArgType :: LHsType Name -> TcM (LHsType Name) +-- The type ty must be an *arg* *type* (lifted or unlifted) +kcArgType ty = kc_check_lhs_type ty ekArg + +--------------------------- kcCheckLHsType :: LHsType Name -> ExpKind -> TcM (LHsType Name) kcCheckLHsType ty kind = addKcTypeCtxt ty $ kc_check_lhs_type ty kind @@ -333,7 +354,8 @@ kc_check_hs_type ty@(HsAppTy ty1 ty2) exp_kind -- 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 + = do { traceTc "kc_check_hs_type" (ppr ty) + ; (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 @@ -361,7 +383,8 @@ 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 + do { traceTc "kc_lhs_type" (ppr ty) + ; (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 @@ -383,9 +406,7 @@ kc_hs_type (HsTyVar name) -- Special case for the unit tycon so it benefits from kind overloading | name == tyConName unitTyCon = kc_hs_type (HsTupleTy (HsBoxyTuple placeHolderKind) []) - | otherwise = do - kind <- kcTyVar name - return (HsTyVar name, kind) + | otherwise = kcTyVar name kc_hs_type (HsListTy ty) = do ty' <- kcLiftedType ty @@ -396,13 +417,14 @@ kc_hs_type (HsPArrTy ty) = do return (HsPArrTy ty', liftedTypeKind) kc_hs_type (HsKindSig ty k) = do - ty' <- kc_check_lhs_type ty (EK k EkKindSig) - return (HsKindSig ty' k, k) + k' <- scDsLHsKind k + ty' <- kc_check_lhs_type ty (EK k' EkKindSig) + return (HsKindSig ty' k, k') kc_hs_type (HsTupleTy (HsBoxyTuple _) tys) = do { fact_tup_ok <- xoptM Opt_ConstraintKinds ; k <- if fact_tup_ok - then newKindVar + then newMetaKindVar else return liftedTypeKind ; tys' <- kcArgs (ptext (sLit "a tuple")) tys k ; return (HsTupleTy (HsBoxyTuple k) tys', k) } @@ -421,10 +443,14 @@ kc_hs_type (HsFunTy ty1 ty2) = do ty2' <- kcTypeType ty2 return (HsFunTy ty1' ty2', liftedTypeKind) -kc_hs_type (HsOpTy ty1 op ty2) = do - op_kind <- addLocM kcTyVar op - ([ty1',ty2'], res_kind) <- kcApps op op_kind [ty1,ty2] - return (HsOpTy ty1' op ty2', res_kind) +kc_hs_type (HsOpTy ty1 (_, l_op@(L loc op)) ty2) = do + (wop, op_kind) <- kcTyVar op + ([ty1',ty2'], res_kind) <- kcApps l_op op_kind [ty1,ty2] + let op' = case wop of + HsTyVar name -> (WpKiApps [], L loc name) + HsWrapTy wrap (HsTyVar name) -> (wrap, L loc name) + _ -> panic "kc_hs_type HsOpTy" + return (HsOpTy ty1' op' ty2', res_kind) kc_hs_type (HsAppTy ty1 ty2) = do let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] @@ -448,17 +474,22 @@ kc_hs_type (HsCoreTy ty) kc_hs_type (HsForAllTy exp tv_names context ty) = kcHsTyVars tv_names $ \ tv_names' -> do { ctxt' <- kcHsContext context - ; ty' <- kcLiftedType ty + ; (ty', k) <- kc_lhs_type ty -- The body of a forall is usually a type, but in principle -- there's no reason to prohibit *unlifted* types. -- In fact, GHC can itself construct a function with an -- unboxed tuple inside a for-all (via CPR analyis; see - -- typecheck/should_compile/tc170) + -- typecheck/should_compile/tc170). + -- + -- Moreover in instance heads we get forall-types with + -- kind Constraint. -- - -- Still, that's only for internal interfaces, which aren't - -- kind-checked, so we only allow liftedTypeKind here + -- Really we should check that it's a type of value kind + -- {*, Constraint, #}, but I'm not doing that yet + -- Example that should be rejected: + -- f :: (forall (a:*->*). a) Int - ; return (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) } + ; return (HsForAllTy exp tv_names' ctxt' ty', k) } kc_hs_type (HsBangTy b ty) = do { (ty', kind) <- kc_lhs_type ty @@ -482,6 +513,17 @@ kc_hs_type (HsQuasiQuoteTy {}) = panic "kc_hs_type" -- Eliminated by renamer kc_hs_type (HsDocTy ty _) = kc_hs_type (unLoc ty) +kc_hs_type (HsExplicitListTy _ tys) + = do { ty_k_s <- mapM kc_lhs_type tys + ; kind <- unifyKinds (ptext (sLit "In a promoted list")) ty_k_s + ; return (HsExplicitListTy kind (map fst ty_k_s), mkListTy kind) } +kc_hs_type (HsExplicitTupleTy _ tys) = do + ty_k_s <- mapM kc_lhs_type tys + return ( HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s) + , mkTyConApp (tupleTyCon BoxedTuple (length tys)) (map snd ty_k_s)) + +kc_hs_type (HsWrapTy {}) = panic "kc_hs_type HsWrapTy" -- it means we kind checked something twice + --------------------------- kcApps :: Outputable a => a @@ -526,16 +568,42 @@ kcHsLPredType :: LHsType Name -> TcM (LHsType Name) kcHsLPredType pred = kc_check_lhs_type pred ekConstraint --------------------------- -kcTyVar :: Name -> TcM TcKind -kcTyVar name = do -- Could be a tyvar or a tycon - traceTc "lk1" (ppr name) - thing <- tcLookup name - traceTc "lk2" (ppr name <+> ppr thing) - case thing of - ATyVar _ ty -> return (typeKind ty) - AThing kind -> return kind - AGlobal (ATyCon tc) -> return (tyConKind tc) - _ -> wrongThingErr "type" thing name +kcTyVar :: Name -> TcM (HsType Name, TcKind) +-- See Note [Type checking recursive type and class declarations] +-- in TcTyClsDecls +kcTyVar name -- Could be a tyvar, a tycon, or a datacon + = do { traceTc "lk1" (ppr name) + ; thing <- tcLookup name + ; traceTc "lk2" (ppr name <+> ppr thing) + ; case thing of + ATyVar _ ty -> wrap_mono (typeKind ty) + AThing kind -> wrap_poly kind + AGlobal (ATyCon tc) -> wrap_poly (tyConKind tc) + AGlobal (ADataCon dc) -> kcDataCon dc >>= wrap_poly + _ -> wrongThingErr "type" thing name } + where + wrap_mono kind = do { traceTc "lk3" (ppr name <+> dcolon <+> ppr kind) + ; return (HsTyVar name, kind) } + wrap_poly kind + | null kvs = wrap_mono kind + | otherwise + = do { traceTc "lk4" (ppr name <+> dcolon <+> ppr kind) + ; kvs' <- mapM (const newMetaKindVar) kvs + ; let ki = substKiWith kvs kvs' ki_body + ; return (HsWrapTy (WpKiApps kvs') (HsTyVar name), ki) } + where (kvs, ki_body) = splitForAllTys kind + +-- IA0_TODO: this function should disapear, and use the dcPromoted field of DataCon +kcDataCon :: DataCon -> TcM TcKind +kcDataCon dc = do + let ty = dataConUserType dc + unless (isPromotableType ty) $ promoteErr dc ty + let ki = promoteType ty + traceTc "prm" (ppr ty <+> ptext (sLit "~~>") <+> ppr ki) + return ki + where + promoteErr dc ty = failWithTc (quotes (ppr dc) <+> ptext (sLit "of type") + <+> quotes (ppr ty) <+> ptext (sLit "is not promotable")) kcClass :: Name -> TcM TcKind kcClass cls = do -- Must be a class @@ -554,22 +622,51 @@ kcClass cls = do -- Must be a class %* * %************************************************************************ -The type desugarer - - * Transforms from HsType to Type - * Zonks any kinds - -It cannot fail, and does no validity checking, except for -structural matters, such as +Note [Desugaring types] +~~~~~~~~~~~~~~~~~~~~~~~ +The type desugarer is phase 2 of dealing with HsTypes. Specifically: + + * It transforms from HsType to Type + + * It zonks any kinds. The returned type should have no mutable kind + or type variables (hence returning Type not TcType): + - any unconstrained kind variables are defaulted to AnyK just + as in TcHsSyn. + - there are no mutable type variables because we are + kind-checking a type + Reason: the returned type may be put in a TyCon or DataCon where + it will never subsequently be zonked. + +You might worry about nested scopes: + ..a:kappa in scope.. + let f :: forall b. T '[a,b] -> Int +In this case, f's type could have a mutable kind variable kappa in it; +and we might then default it to AnyK when dealing with f's type +signature. But we don't expect this to happen because we can't get a +lexically scoped type variable with a mutable kind variable in it. A +delicate point, this. If it becomes an issue we might need to +distinguish top-level from nested uses. + +Moreover + * it cannot fail, + * it does no unifications + * it does no validity checking, except for structural matters, such as (a) spurious ! annotations. (b) a class used as a type \begin{code} + +zonkTcKindToKind :: TcKind -> TcM Kind +-- When zonking a TcKind to a kind we instantiate kind variables to AnyK +zonkTcKindToKind = zonkType (mkZonkTcTyVar (\ _ -> return anyKind) mkTyVarTy) + dsHsType :: LHsType Name -> TcM Type -- All HsTyVarBndrs in the intput type are kind-annotated +-- See Note [Desugaring types] dsHsType ty = ds_type (unLoc ty) ds_type :: HsType Name -> TcM Type +-- See Note [Desugaring types] ds_type ty@(HsTyVar _) = ds_app ty [] @@ -599,7 +696,10 @@ ds_type (HsTupleTy hs_con tys) = do con <- case hs_con of HsUnboxedTuple -> return UnboxedTuple HsBoxyTuple kind -> do - kind' <- zonkTcKindToKind kind + -- Here we use zonkTcKind instead of zonkTcKindToKind because pairs + -- are a special case: we use them both for types (eg. (Int, Bool)) + -- and for constraints (eg. (Show a, Eq a)) + kind' <- zonkTcKind kind case () of _ | kind' `eqKind` constraintKind -> return ConstraintTuple _ | kind' `eqKind` liftedTypeKind -> return BoxedTuple @@ -615,10 +715,8 @@ ds_type (HsFunTy ty1 ty2) = do tau_ty2 <- dsHsType ty2 return (mkFunTy tau_ty1 tau_ty2) -ds_type (HsOpTy ty1 (L span op) ty2) = do - tau_ty1 <- dsHsType ty1 - tau_ty2 <- dsHsType ty2 - setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2]) +ds_type (HsOpTy ty1 (wrap, (L span op)) ty2) = + setSrcSpan span (ds_app (HsWrapTy wrap (HsTyVar op)) [ty1,ty2]) ds_type ty@(HsAppTy _ _) = ds_app ty [] @@ -633,7 +731,7 @@ ds_type (HsEqTy ty1 ty2) = do return (mkEqPred (tau_ty1, tau_ty2)) ds_type (HsForAllTy _ tv_names ctxt ty) - = tcTyVarBndrs tv_names $ \ tyvars -> do + = tcTyVarBndrsKindGen tv_names $ \ tyvars -> do theta <- mapM dsHsType (unLoc ctxt) tau <- dsHsType ty return (mkSigmaTy tyvars theta tau) @@ -642,16 +740,51 @@ ds_type (HsDocTy ty _) -- Remove the doc comment = dsHsType ty ds_type (HsSpliceTy _ _ kind) - = do { kind' <- zonkTcKindToKind kind + = do { kind' <- zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind) mkTyVarTy) + kind + -- See Note [Kind of a type splice] ; newFlexiTyVarTy kind' } ds_type (HsQuasiQuoteTy {}) = panic "ds_type" -- Eliminated by renamer ds_type (HsCoreTy ty) = return ty +ds_type (HsExplicitListTy kind tys) = do + kind' <- zonkTcKindToKind kind + ds_tys <- mapM dsHsType tys + return $ + foldr (\a b -> mkTyConApp (buildPromotedDataTyCon consDataCon) [kind', a, b]) + (mkTyConApp (buildPromotedDataTyCon nilDataCon) [kind']) ds_tys + +ds_type (HsExplicitTupleTy kis tys) = do + MASSERT( length kis == length tys ) + kis' <- mapM zonkTcKindToKind kis + tys' <- mapM dsHsType tys + return $ mkTyConApp (buildPromotedDataTyCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys') + +ds_type (HsWrapTy (WpKiApps kappas) ty) = do + tau <- ds_type ty + kappas' <- mapM zonkTcKindToKind kappas + return (mkAppTys tau kappas') + dsHsTypes :: [LHsType Name] -> TcM [Type] dsHsTypes arg_tys = mapM dsHsType arg_tys \end{code} +Note [Kind of a type splice] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these terms, each with TH type splice inside: + [| e1 :: Maybe $(..blah..) |] + [| e2 :: $(..blah..) |] +When kind-checking the type signature, we'll kind-check the splice +$(..blah..); we want to give it a kind that can fit in any context, +as if $(..blah..) :: forall k. k. + +In the e1 example, the context of the splice fixes kappa to *. But +in the e2 example, we'll desugar the type, zonking the kind unification +variables as we go. When we encournter the unconstrained kappa, we +want to default it to '*', not to AnyK. + + Help functions for type applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -668,15 +801,22 @@ ds_app ty tys = do 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) - AGlobal (ATyCon tc) -> return (mkTyConApp tc arg_tys) - _ -> wrongThingErr "type" thing name -\end{code} +-- See Note [Type checking recursive type and class declarations] +-- in TcTyClsDecls +ds_var_app name arg_tys + | isTvNameSpace (rdrNameSpace (nameRdrName name)) + = do { thing <- tcLookup name + ; case thing of + ATyVar _ ty -> return (mkAppTys ty arg_tys) + _ -> wrongThingErr "type" thing name } + + | otherwise + = do { thing <- tcLookupGlobal name + ; case thing of + ATyCon tc -> return (mkTyConApp tc arg_tys) + ADataCon dc -> return (mkTyConApp (buildPromotedDataTyCon dc) arg_tys) + _ -> wrongThingErr "type" (AGlobal thing) name } -\begin{code} addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a -- Wrap a context around only if we want to show that contexts. -- Omit invisble ones and ones user's won't grok @@ -692,6 +832,20 @@ typeCtxt ty = ptext (sLit "In the type") <+> quotes (ppr ty) %* * %************************************************************************ +Note [Kind-checking kind-polymorphic types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + f :: forall (f::k -> *) a. f a -> Int + +Here, the [LHsTyVarBndr Name] of the forall type will be [f,a], where + a is a UserTyVar -> type variable without kind annotation + f is a KindedTyVar -> type variable with kind annotation + +If were were to allow binding sites for kind variables, thus + f :: forall @k (f :: k -> *) a. f a -> Int +then we'd also need + k is a UserKiVar -> kind variable (they don't need annotation, + since we only have BOX for a super kind) \begin{code} kcHsTyVars :: [LHsTyVarBndr Name] @@ -703,33 +857,141 @@ kcHsTyVars tvs thing_inside ; tcExtendKindEnvTvs kinded_tvs thing_inside } kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name) - -- Return a *kind-annotated* binder, and a tyvar with a mutable kind in it -kcHsTyVar (UserTyVar name _) = UserTyVar name <$> newKindVar -kcHsTyVar tv@(KindedTyVar {}) = return tv +-- Return a *kind-annotated* binder, whose PostTcKind is +-- initialised with a kind variable. +-- Typically the Kind inside the KindedTyVar will be a tyvar with a mutable kind +-- in it. We aren't yet sure whether the binder is a *type* variable or a *kind* +-- variable. See Note [Kind-checking kind-polymorphic types] +-- +-- If the variable is already in scope return it, instead of introducing a new +-- one. This can occur in +-- instance C (a,b) where +-- type F (a,b) c = ... +-- Here a,b will be in scope when processing the associated type instance for F. +kcHsTyVar tyvar = do in_scope <- getInLocalScope + if in_scope (hsTyVarName tyvar) + then do inscope_tyvar <- tcLookupTyVar (hsTyVarName tyvar) + return (UserTyVar (tyVarName inscope_tyvar) + (tyVarKind inscope_tyvar)) + else kcHsTyVar' tyvar + where + kcHsTyVar' (UserTyVar name _) = UserTyVar name <$> newMetaKindVar + kcHsTyVar' (KindedTyVar name kind _) = do + kind' <- scDsLHsKind kind + return (KindedTyVar name kind kind') ------------------ -tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking - -> ([TyVar] -> TcM r) - -> TcM r +tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking + -> ([TyVar] -> TcM r) + -> TcM r -- Used when type-checking types/classes/type-decls -- Brings into scope immutable TyVars, not mutable ones that require later zonking +-- Fix #5426: avoid abstraction over kinds containing # or (#) tcTyVarBndrs bndrs thing_inside = do - tyvars <- mapM (zonk . unLoc) bndrs + tyvars <- mapM (zonk . hsTyVarNameKind . unLoc) bndrs tcExtendTyVarEnv tyvars (thing_inside tyvars) where - zonk (UserTyVar name kind) = do { kind' <- zonkTcKindToKind kind - ; return (mkTyVar name kind') } - zonk (KindedTyVar name kind) = return (mkTyVar name kind) + zonk (name, kind) + = do { kind' <- zonkTcKind kind + ; checkTc (noHashInKind kind') (ptext (sLit "Kind signature contains # or (#)")) + ; return (mkTyVar name kind') } + +tcTyVarBndrsKindGen :: [LHsTyVarBndr Name] -> ([TyVar] -> TcM r) -> TcM r +-- tcTyVarBndrsKindGen [(f :: ?k -> *), (a :: ?k)] thing_inside +-- calls thing_inside with [(k :: BOX), (f :: k -> *), (a :: k)] +tcTyVarBndrsKindGen bndrs thing_inside + = do { let kinds = map (hsTyVarKind . unLoc) bndrs + ; (kvs, zonked_kinds) <- kindGeneralizeKinds kinds + ; let tyvars = zipWith mkTyVar (map hsLTyVarName bndrs) zonked_kinds + ktvs = kvs ++ tyvars -- See Note [Kinds of quantified type variables] + ; traceTc "tcTyVarBndrsKindGen" (ppr (bndrs, kvs, tyvars)) + ; tcExtendTyVarEnv ktvs (thing_inside ktvs) } +\end{code} + +Note [Kinds of quantified type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcTyVarBndrsKindGen quantifies over a specified list of type variables, +*and* over the kind variables mentioned in the kinds of those tyvars. + +Note that we must zonk those kinds (obviously) but less obviously, we +must return type variables whose kinds are zonked too. Example + (a :: k7) where k7 := k9 -> k9 +We must return + [k9, a:k9->k9] +and NOT + [k9, a:k7] +Reason: we're going to turn this into a for-all type, + forall k9. forall (a:k7). blah +which the type checker will then instantiate, and instantiate does not +look through unification variables! + +Hence using zonked_kinds when forming 'tyvars'. + +\begin{code} +tcTyClTyVars :: Name -> [LHsTyVarBndr Name] -- LHS of the type or class decl + -> ([TyVar] -> Kind -> TcM a) -> TcM a +-- tcTyClTyVars T [a,b] calls thing_inside with +-- [k1,k2,a,b] (k2 -> *) where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> * +-- +-- No need to freshen the k's because they are just skolem +-- constants here, and we are at top level anyway. +tcTyClTyVars tycon tyvars thing_inside + = do { thing <- tcLookup tycon + ; let { kind = + case thing of + AThing kind -> kind + _ -> panic "tcTyClTyVars" + -- We only call tcTyClTyVars during typechecking in + -- TcTyClDecls, where the local env is extended with + -- the generalized_env (mapping Names to AThings). + ; (kvs, body) = splitForAllTys kind + ; (kinds, res) = splitKindFunTysN (length names) body + ; names = hsLTyVarNames tyvars + ; tvs = zipWith mkTyVar names kinds + ; all_vs = kvs ++ tvs } + ; tcExtendTyVarEnv all_vs (thing_inside all_vs res) } + +-- Used when generalizing binders and type family patterns +-- It takes a kind from the type checker (like `k0 -> *`), and returns the +-- final, kind-generalized kind (`forall k::BOX. k -> *`) +kindGeneralizeKinds :: [TcKind] -> TcM ([KindVar], [Kind]) +-- INVARIANT: the returned kinds are zonked, and +-- mention the returned kind variables +kindGeneralizeKinds kinds + = do { -- Quantify over kind variables free in + -- the kinds, and *not* in the environment + ; zonked_kinds <- mapM zonkTcKind kinds + ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked + ; let kvs_to_quantify = tyVarsOfTypes zonked_kinds + `minusVarSet` gbl_tvs + + ; kvs <- ASSERT2 (all isKiVar (varSetElems kvs_to_quantify), ppr kvs_to_quantify) + zonkQuantifiedTyVars kvs_to_quantify + + -- Zonk the kinds again, to pick up either the kind + -- variables we quantify over, or *, depending on whether + -- zonkQuantifiedTyVars decided to generalise (which in + -- turn depends on PolyKinds) + ; final_kinds <- mapM zonkTcKind zonked_kinds + + ; traceTc "generalizeKind" ( ppr kinds <+> ppr kvs_to_quantify + <+> ppr kvs <+> ppr final_kinds) + ; return (kvs, final_kinds) } + +kindGeneralizeKind :: TcKind -> TcM ( [KindVar] -- these were flexi kind vars + , Kind ) -- this is the old kind where flexis got zonked +kindGeneralizeKind kind = do + (kvs, [kind']) <- kindGeneralizeKinds [kind] + return (kvs, kind') ----------------------------------- -tcDataKindSig :: Maybe Kind -> TcM [TyVar] +tcDataKindSig :: Kind -> TcM [TyVar] -- GADT decls can have a (perhaps partial) kind signature -- e.g. data T :: * -> * -> * where ... -- This function makes up suitable (kinded) type variables for -- the argument kinds, and checks that the result kind is indeed *. -- We use it also to make up argument type variables for for data instances. -tcDataKindSig Nothing = return [] -tcDataKindSig (Just kind) +tcDataKindSig kind = do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind) ; span <- getSrcSpanM ; us <- newUniqueSupply @@ -932,12 +1194,22 @@ data EkCtxt = EkUnk -- Unknown context | EkIParam -- Implicit parameter type | EkFamInst -- Family instance +instance Outputable ExpKind where + ppr (EK k _) = ptext (sLit "Expected kind:") <+> ppr k -ekLifted, ekOpen, ekConstraint :: ExpKind +ekLifted, ekOpen, ekArg, ekConstraint :: ExpKind ekLifted = EK liftedTypeKind EkUnk ekOpen = EK openTypeKind EkUnk +ekArg = EK argTypeKind EkUnk ekConstraint = EK constraintKind EkUnk +unifyKinds :: SDoc -> [(LHsType Name, TcKind)] -> TcM TcKind +unifyKinds fun act_kinds = do + kind <- newMetaKindVar + let exp_kind arg_no = EK kind (EkArg fun arg_no) + mapM_ (\(arg_no, (ty, act_kind)) -> checkExpectedKind ty act_kind (exp_kind arg_no)) (zip [1..] act_kinds) + return kind + checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM () -- A fancy wrapper for 'unifyKind', which tries -- to give decent error messages. @@ -945,8 +1217,9 @@ checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM () -- checks that the actual kind act_kind is compatible -- with the expected kind exp_kind -- The first argument, ty, is used only in the error message generation -checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) = do - (_errs, mb_r) <- tryTc (unifyKind exp_kind act_kind) +checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) = do + traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind $$ ppr ek) + (_errs, mb_r) <- tryTc (unifyKind act_kind exp_kind) case mb_r of Just _ -> return () -- Unification succeeded Nothing -> do @@ -962,8 +1235,8 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) = do n_exp_as = length exp_as n_act_as = length act_as - (env1, tidy_exp_kind) = tidyKind env0 exp_kind - (env2, tidy_act_kind) = tidyKind env1 act_kind + (env1, tidy_exp_kind) = tidyOpenKind env0 exp_kind + (env2, tidy_act_kind) = tidyOpenKind env1 act_kind err | n_exp_as < n_act_as -- E.g. [Maybe] = quotes (ppr ty) <+> ptext (sLit "is not applied to enough type arguments") @@ -1005,6 +1278,100 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) = do \end{code} %************************************************************************ +%* * + Sort checking kinds +%* * +%************************************************************************ + +scDsLHsKind converts a user-written kind to an internal, sort-checked kind. +It does sort checking and desugaring at the same time, in one single pass. +It fails when the kinds are not well-formed (eg. data A :: * Int), or if there +are non-promotable or non-fully applied kinds. + +\begin{code} +scDsLHsKind :: LHsKind Name -> TcM Kind +scDsLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $ + sc_ds_lhs_kind k + +scDsLHsMaybeKind :: Maybe (LHsKind Name) -> TcM (Maybe Kind) +scDsLHsMaybeKind Nothing = return Nothing +scDsLHsMaybeKind (Just k) = do k' <- scDsLHsKind k + return (Just k') + +sc_ds_lhs_kind :: LHsKind Name -> TcM Kind +sc_ds_lhs_kind (L span ki) = setSrcSpan span (sc_ds_hs_kind ki) + +-- The main worker +sc_ds_hs_kind :: HsKind Name -> TcM Kind +sc_ds_hs_kind k@(HsTyVar _) = sc_ds_app k [] +sc_ds_hs_kind k@(HsAppTy _ _) = sc_ds_app k [] + +sc_ds_hs_kind (HsParTy ki) = sc_ds_lhs_kind ki + +sc_ds_hs_kind (HsFunTy ki1 ki2) = + do kappa_ki1 <- sc_ds_lhs_kind ki1 + kappa_ki2 <- sc_ds_lhs_kind ki2 + return (mkArrowKind kappa_ki1 kappa_ki2) + +sc_ds_hs_kind (HsListTy ki) = + do kappa <- sc_ds_lhs_kind ki + checkWiredInTyCon listTyCon + return $ mkListTy kappa + +sc_ds_hs_kind (HsTupleTy _ kis) = + do kappas <- mapM sc_ds_lhs_kind kis + checkWiredInTyCon tycon + return $ mkTyConApp tycon kappas + where tycon = tupleTyCon BoxedTuple (length kis) + +-- Argument not kind-shaped +sc_ds_hs_kind k = panic ("sc_ds_hs_kind: " ++ showPpr k) + +-- Special case for kind application +sc_ds_app :: HsKind Name -> [LHsKind Name] -> TcM Kind +sc_ds_app (HsAppTy ki1 ki2) kis = sc_ds_app (unLoc ki1) (ki2:kis) +sc_ds_app (HsTyVar tc) kis = + do arg_kis <- mapM sc_ds_lhs_kind kis + sc_ds_var_app tc arg_kis +sc_ds_app ki _ = failWithTc (quotes (ppr ki) <+> + ptext (sLit "is not a kind constructor")) + +-- IA0_TODO: With explicit kind polymorphism I might need to add ATyVar +sc_ds_var_app :: Name -> [Kind] -> TcM Kind +-- Special case for * and Constraint kinds +sc_ds_var_app name arg_kis + | name == liftedTypeKindTyConName + || name == constraintKindTyConName = do + unless (null arg_kis) + (failWithTc (text "Kind" <+> ppr name <+> text "cannot be applied")) + thing <- tcLookup name + case thing of + AGlobal (ATyCon tc) -> return (mkTyConApp tc []) + _ -> panic "sc_ds_var_app 1" + +-- General case +sc_ds_var_app name arg_kis = do + thing <- tcLookup name + case thing of + AGlobal (ATyCon tc) + | isAlgTyCon tc || isTupleTyCon tc -> do + poly_kinds <- xoptM Opt_PolyKinds + unless poly_kinds $ addErr (polyKindsErr name) + let tc_kind = tyConKind tc + case isPromotableKind tc_kind of + Just n | n == length arg_kis -> + 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 + + where err k m = failWithTc ( quotes (ppr name) <+> ptext (sLit "of kind") + <+> quotes (ppr k) <+> ptext (sLit m)) + +\end{code} + +%************************************************************************ %* * Scoped type variables %* * diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 01bffce61d..837f3823ba 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -454,16 +454,15 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags)) badBootDeclErr - ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty - ; checkValidInstance poly_ty tyvars theta clas inst_tys + ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) -- Next, process any associated types. ; traceTc "tcLocalInstDecl" (ppr poly_ty) ; idx_tycons0 <- tcExtendTyVarEnv tyvars $ - mapAndRecoverM (tcAssocDecl clas mini_env) ats + mapAndRecoverM (tcAssocDecl clas mini_env) ats - -- Check for misssing associated types and build them + -- Check for missing associated types and build them -- from their defaults (if available) ; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats check_at_instance (fam_tc, defs) @@ -473,7 +472,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) | null defs = return (Just (tyConName fam_tc), []) -- No user instance, have defaults ==> instatiate them | otherwise = do - defs' <- forM defs $ \(ATD tvs pat_tys rhs) -> do + defs' <- forM defs $ \(ATD tvs pat_tys rhs _loc) -> do let mini_env_subst = mkTvSubst (mkInScopeSet (mkVarSet tvs)) mini_env tvs' = varSetElems (tyVarsOfType rhs') pat_tys' = substTys mini_env_subst pat_tys @@ -526,6 +525,7 @@ tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM TyCon tcFamInstDecl top_lvl decl = do { -- type family instances require -XTypeFamilies -- and can't (currently) be in an hs-boot file + ; traceTc "tcFamInstDecl" (ppr decl) ; let fam_tc_lname = tcdLName decl ; type_families <- xoptM Opt_TypeFamilies ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? @@ -551,13 +551,8 @@ tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM TyCon -- "type instance" tcFamInstDecl1 fam_tc (decl@TySynonym {}) - = kcFamTyPats decl $ \k_tvs k_typats resKind -> - do { -- kind check the right-hand side of the type equation - ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) - -- ToDo: the ExpKind could be better - - -- (1) do the work of verifying the synonym - ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc (decl { tcdTyVars = k_tvs, tcdTyPats = Just k_typats, tcdSynRhs = k_rhs }) + = do { -- (1) do the work of verifying the synonym + ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc decl -- (2) check the well-formedness of the instance ; checkValidFamInst t_typats t_rhs @@ -571,59 +566,50 @@ tcFamInstDecl1 fam_tc (decl@TySynonym {}) } -- "newtype instance" and "data instance" -tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data - , tcdCons = cons}) - = kcFamTyPats decl $ \k_tvs k_typats resKind -> - do { -- check that the family declaration is for the right kind +tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt + , tcdTyVars = tvs, tcdTyPats = Just pats + , tcdCons = cons}) + = do { -- Check that the family declaration is for the right kind checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; -- (1) kind check the data declaration as usual - ; k_decl <- kcDataDecl decl k_tvs - ; let k_ctxt = tcdCtxt k_decl - k_cons = tcdCons k_decl - - -- result kind must be '*' (otherwise, we have too few patterns) - ; resKind' <- zonkTcKindToKind resKind -- Remember: kcFamTyPats supplies unzonked kind! - ; checkTc (isLiftedTypeKind resKind') $ tooFewParmsErr (tyConArity fam_tc) - - -- (2) type check indexed data type declaration - ; tcTyVarBndrs k_tvs $ \t_tvs -> do -- turn kinded into proper tyvars + -- Kind check type patterns + ; tcFamTyPats fam_tc tvs pats (\_always_star -> kcDataDecl decl) $ + \tvs' pats' resultKind -> do - -- kind check the type indexes and the context - { t_typats <- mapM tcHsKindedType k_typats - ; stupid_theta <- tcHsKindedContext k_ctxt + -- Check that left-hand side contains no type family applications + -- (vanilla synonyms are fine, though, and we checked for + -- foralls earlier) + { mapM_ checkTyFamFreeness pats' + + -- Result kind must be '*' (otherwise, we have too few patterns) + ; checkTc (isLiftedTypeKind resultKind) $ tooFewParmsErr (tyConArity fam_tc) - -- (3) Check that - -- (a) left-hand side contains no type family applications - -- (vanilla synonyms are fine, though, and we checked for - -- foralls earlier) - ; mapM_ checkTyFamFreeness t_typats + ; stupid_theta <- tcHsKindedContext =<< kcHsContext ctxt + ; dataDeclChecks (tcdName decl) new_or_data stupid_theta cons - ; dataDeclChecks (tcdName decl) new_or_data stupid_theta k_cons - - -- (4) construct representation tycon - ; rep_tc_name <- newFamInstTyConName (tcdLName decl) t_typats + -- Construct representation tycon + ; rep_tc_name <- newFamInstTyConName (tcdLName decl) pats' ; let ex_ok = True -- Existentials ok for type families! ; fixM (\ rep_tycon -> do - { let orig_res_ty = mkTyConApp fam_tc t_typats - ; data_cons <- tcConDecls ex_ok rep_tycon - (t_tvs, orig_res_ty) k_cons + { let orig_res_ty = mkTyConApp fam_tc pats' + ; data_cons <- tcConDecls new_or_data ex_ok rep_tycon + (tvs', orig_res_ty) cons ; tc_rhs <- case new_or_data of DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs rep_tc_name rep_tycon (head data_cons) - ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive - h98_syntax NoParentTyCon (Just (fam_tc, t_typats)) + ; buildAlgTyCon rep_tc_name tvs' stupid_theta tc_rhs Recursive + h98_syntax NoParentTyCon (Just (fam_tc, pats')) -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a -- further instance might not introduce a new recursive -- dependency. (2) They are always valid loop breakers as -- they involve a coercion. }) - }} - where + } } + where h98_syntax = case cons of -- All constructors have same shape L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False _ -> True @@ -644,9 +630,9 @@ tcAssocDecl clas mini_env (L loc decl) -- Check that the associated type comes from this class ; checkTc (Just clas == tyConAssoc_maybe fam_tc) - (badATErr clas (tyConName at_tc)) + (badATErr (className clas) (tyConName at_tc)) - -- See Note [Checking consistent instantiation] + -- See Note [Checking consistent instantiation] in TcTyClsDecls ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys ; return at_tc } @@ -914,7 +900,7 @@ tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag tcSpecInst dfun_id prag@(SpecInstSig hs_ty) = addErrCtxt (spec_ctxt prag) $ do { let name = idName dfun_id - ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty + ; (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 5315c20dd1..a4e87345f4 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -622,7 +622,8 @@ trySpontaneousEqOneWay eqv gw tv xi | not (isSigTyVar tv) || isTyVarTy xi = do { let kxi = typeKind xi -- NB: 'xi' is fully rewritten according to the inerts -- so we have its more specific kind in our hands - ; if kxi `isSubKind` tyVarKind tv then + ; is_sub_kind <- kxi `isSubKindTcS` tyVarKind tv + ; if is_sub_kind then solveWithIdentity eqv gw tv xi else return SPCantSolve {- @@ -642,18 +643,32 @@ trySpontaneousEqOneWay eqv gw tv xi trySpontaneousEqTwoWay :: EqVar -> CtFlavor -> TcTyVar -> TcTyVar -> TcS SPSolveResult -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here trySpontaneousEqTwoWay eqv gw tv1 tv2 - | k1 `isSubKind` k2 - , nicer_to_update_tv2 = solveWithIdentity eqv gw tv2 (mkTyVarTy tv1) - | k2 `isSubKind` k1 - = solveWithIdentity eqv gw tv1 (mkTyVarTy tv2) - | otherwise -- None is a subkind of the other, but they are both touchable! - = return SPCantSolve - -- do { addErrorTcS KindError gw (mkTyVarTy tv1) (mkTyVarTy tv2) - -- ; return SPError } + = do { k1_sub_k2 <- k1 `isSubKindTcS` k2 + ; if k1_sub_k2 && nicer_to_update_tv2 + then solveWithIdentity eqv gw tv2 (mkTyVarTy tv1) + else do + { k2_sub_k1 <- k2 `isSubKindTcS` k1 + ; MASSERT( k2_sub_k1 ) -- they were unified in TcCanonical + ; solveWithIdentity eqv gw tv1 (mkTyVarTy tv2) } } where k1 = tyVarKind tv1 k2 = tyVarKind tv2 nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2) +{- +-- Previous code below (before kind polymorphism and unification): + -- | k1 `isSubKind` k2 + -- , nicer_to_update_tv2 = solveWithIdentity eqv gw tv2 (mkTyVarTy tv1) + -- | k2 `isSubKind` k1 + -- = solveWithIdentity eqv gw tv1 (mkTyVarTy tv2) + -- | otherwise -- None is a subkind of the other, but they are both touchable! + -- = return SPCantSolve + -- -- do { addErrorTcS KindError gw (mkTyVarTy tv1) (mkTyVarTy tv2) + -- -- ; return SPError } + -- where + -- k1 = tyVarKind tv1 + -- k2 = tyVarKind tv2 + -- nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2) +-} \end{code} Note [Kind errors] diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 032516bd41..3f88cbbf86 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -24,7 +24,7 @@ module TcMType ( newFlexiTyVar, newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] - newKindVar, newKindVars, + newMetaKindVar, newMetaKindVars, mkTcTyVarName, newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, @@ -48,7 +48,7 @@ module TcMType ( -------------------------------- -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, - SourceTyCtxt(..), checkValidTheta, + checkValidTheta, checkValidInstHead, checkValidInstance, validDerivPred, checkInstTermination, checkValidFamInst, checkTyFamFreeness, arityErr, @@ -56,19 +56,18 @@ module TcMType ( -------------------------------- -- Zonking - zonkType, mkZonkTcTyVar, zonkTcPredType, + zonkType, zonkKind, zonkTcPredType, zonkTcTypeCarefully, skolemiseUnboundMetaTyVar, zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar, zonkQuantifiedTyVar, zonkQuantifiedTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType, - zonkTcKindToKind, zonkTcKind, + zonkTcKind, defaultKindVarToStar, zonkImplication, zonkEvVar, zonkWantedEvVar, zonkFlavoredEvVar, zonkWC, zonkWantedEvVars, zonkTcTypeAndSubst, tcGetGlobalTyVars, - - readKindVar, writeKindVar + compatKindTcM, isSubKindTcM ) where #include "HsVersions.h" @@ -77,6 +76,7 @@ module TcMType ( import TypeRep import TcType import Type +import Kind import Class import TyCon import Var @@ -102,7 +102,7 @@ import Unique( Unique ) import Bag import Control.Monad -import Data.List ( (\\) ) +import Data.List ( (\\), partition ) \end{code} @@ -113,13 +113,13 @@ import Data.List ( (\\) ) %************************************************************************ \begin{code} -newKindVar :: TcM TcKind -newKindVar = do { uniq <- newUnique +newMetaKindVar :: TcM TcKind +newMetaKindVar = do { uniq <- newUnique ; ref <- newMutVar Flexi - ; return (mkTyVarTy (mkKindVar uniq ref)) } + ; return (mkTyVarTy (mkMetaKindVar uniq ref)) } -newKindVars :: Int -> TcM [TcKind] -newKindVars n = mapM (\ _ -> newKindVar) (nOfThem n ()) +newMetaKindVars :: Int -> TcM [TcKind] +newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ()) \end{code} @@ -209,17 +209,24 @@ tcSkolDFunType ty = tcInstType (\tvs -> return (tcSuperSkolTyVars tvs)) ty tcSuperSkolTyVars :: [TyVar] -> [TcTyVar] -- Make skolem constants, but do *not* give them new names, as above -- Moreover, make them "super skolems"; see comments with superSkolemTv -tcSuperSkolTyVars tyvars - = [ mkTcTyVar (tyVarName tv) (tyVarKind tv) superSkolemTv - | tv <- tyvars ] - -tcInstSkolTyVar :: Bool -> TyVar -> TcM TcTyVar +-- see Note [Kind substitution when instantiating] +tcSuperSkolTyVars tyvars -- IA0_NOTE: should be ordered (kind vars first) + = kvs' ++ tvs' + where + (kvs, tvs) = splitKiTyVars tyvars + kvs' = [ mkTcTyVar (tyVarName kv) (tyVarKind kv) superSkolemTv + | kv <- kvs ] + tvs' = [ mkTcTyVar (tyVarName tv) (substTy subst (tyVarKind tv)) superSkolemTv + | tv <- tvs ] + subst = zipTopTvSubst kvs (map mkTyVarTy kvs') + +tcInstSkolTyVar :: Bool -> TvSubst -> TyVar -> TcM TcTyVar -- Instantiate the tyvar, using -- * the occ-name and kind of the supplied tyvar, -- * the unique from the monad, -- * the location either from the tyvar (skol_info = SigSkol) -- or from the monad (otherwise) -tcInstSkolTyVar overlappable tyvar +tcInstSkolTyVar overlappable subst tyvar = do { uniq <- newUnique ; loc <- getSrcSpanM ; let new_name = mkInternalName uniq occ loc @@ -227,13 +234,27 @@ tcInstSkolTyVar overlappable tyvar where old_name = tyVarName tyvar occ = nameOccName old_name - kind = tyVarKind tyvar + kind = substTy subst (tyVarKind tyvar) tcInstSkolTyVars :: [TyVar] -> TcM [TcTyVar] -tcInstSkolTyVars tyvars = mapM (tcInstSkolTyVar False) tyvars +-- Precondition: tyvars should be ordered (kind vars first) +-- see Note [Kind substitution when instantiating] +tcInstSkolTyVars tyvars + = do { kvs' <- mapM (tcInstSkolTyVar False (mkTopTvSubst [])) kvs + ; tvs' <- mapM (tcInstSkolTyVar False (zipTopTvSubst kvs (map mkTyVarTy kvs'))) tvs + ; return (kvs' ++ tvs') } + where (kvs, tvs) = splitKiTyVars tyvars tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar] -tcInstSuperSkolTyVars tyvars = mapM (tcInstSkolTyVar True) tyvars +-- Precondition: tyvars should be ordered (kind vars first) +-- see Note [Kind substitution when instantiating] + +-- JPM: do this with mapAccumLM +tcInstSuperSkolTyVars tyvars + = do { kvs' <- mapM (tcInstSkolTyVar True (mkTopTvSubst [])) kvs + ; tvs' <- mapM (tcInstSkolTyVar True (zipTopTvSubst kvs (map mkTyVarTy kvs'))) tvs + ; return (kvs' ++ tvs') } + where (kvs, tvs) = splitKiTyVars tyvars tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type with fresh skolem constants @@ -243,19 +264,40 @@ tcInstSkolType ty = tcInstType tcInstSkolTyVars ty tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar] -- Make meta SigTv type variables for patten-bound scoped type varaibles -- We use SigTvs for them, so that they can't unify with arbitrary types -tcInstSigTyVars = mapM tcInstSigTyVar - -tcInstSigTyVar :: TyVar -> TcM TcTyVar -tcInstSigTyVar tyvar - = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi - ; let name = setNameUnique (tyVarName tyvar) uniq - -- Use the same OccName so that the tidy-er - -- doesn't rename 'a' to 'a0' etc - kind = tyVarKind tyvar - ; return (mkTcTyVar name kind (MetaTv SigTv ref)) } +-- Precondition: tyvars should be ordered (kind vars first) +-- see Note [Kind substitution when instantiating] +tcInstSigTyVars tyvars + = do { kvs' <- mapM (tcInstSigTyVar (mkTopTvSubst [])) kvs + ; tvs' <- mapM (tcInstSigTyVar (zipTopTvSubst kvs (map mkTyVarTy kvs'))) tvs + ; return (kvs' ++ tvs') } + where (kvs, tvs) = splitKiTyVars tyvars + +tcInstSigTyVar :: TvSubst -> TyVar -> TcM TcTyVar +tcInstSigTyVar subst tyvar + = do { uniq <- newMetaUnique + ; ref <- newMutVar Flexi + ; let name = setNameUnique (tyVarName tyvar) uniq + -- Use the same OccName so that the tidy-er + -- doesn't rename 'a' to 'a0' etc + kind = substTy subst (tyVarKind tyvar) + ; return (mkTcTyVar name kind (MetaTv SigTv ref)) } \end{code} +Note [Kind substitution when instantiating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we instantiate a bunch of kind and type variables, first we +expect them to be sorted (kind variables first, then type variables). +Then we have to instantiate the kind variables, build a substitution +from old variables to the new variables, then instantiate the type +variables substituting the original kind. + +Exemple: If we want to instantiate + [(k1 :: BOX), (k2 :: BOX), (a :: k1 -> k2), (b :: k1)] +we want + [(?k1 :: BOX), (?k2 :: BOX), (?a :: ?k1 -> ?k2), (?b :: ?k1)] +instead of the buggous + [(?k1 :: BOX), (?k2 :: BOX), (?a :: k1 -> k2), (?b :: k1)] + %************************************************************************ %* * @@ -281,6 +323,7 @@ mkTcTyVarName :: Unique -> FastString -> Name -- leaving the un-cluttered names free for user names mkTcTyVarName uniq str = mkSysTvName uniq str +-- Works for both type and kind variables readMetaTyVar :: TyVar -> TcM MetaDetails readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) readMutVar (metaTvRef tyvar) @@ -304,6 +347,7 @@ isFlexiMetaTyVar tv | otherwise = return False -------------------- +-- Works with both type and kind variables writeMetaTyVar :: TcTyVar -> TcType -> TcM () -- Write into a currently-empty MetaTyVar @@ -333,20 +377,27 @@ writeMetaTyVarRef tyvar ref ty ; writeMutVar ref (Indirect ty) } -- Everything from here on only happens if DEBUG is on - | not (isPredTy tv_kind) -- Don't check kinds for updates to coercion variables - , not (ty_kind `isSubKind` tv_kind) - = WARN( True, hang (text "Ill-kinded update to meta tyvar") - 2 (ppr tyvar $$ ppr tv_kind $$ ppr ty $$ ppr ty_kind) ) - return () - | otherwise = do { meta_details <- readMutVar ref; + -- Zonk kinds to allow the error check to work + ; zonked_tv_kind <- zonkTcKind tv_kind + ; zonked_ty_kind <- zonkTcKind ty_kind + + -- Check for double updates ; ASSERT2( isFlexi meta_details, hang (text "Double update of meta tyvar") 2 (ppr tyvar $$ ppr meta_details) ) traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) - ; writeMutVar ref (Indirect ty) } + ; writeMutVar ref (Indirect ty) + ; when ( not (isPredTy tv_kind) + -- Don't check kinds for updates to coercion variables + && not (zonked_ty_kind `isSubKind` zonked_tv_kind)) + $ WARN( True, hang (text "Ill-kinded update to meta tyvar") + 2 ( ppr tyvar <+> text "::" <+> ppr tv_kind + <+> text ":=" + <+> ppr ty <+> text "::" <+> ppr ty_kind) ) + (return ()) } where tv_kind = tyVarKind tyvar ty_kind = typeKind ty @@ -373,23 +424,26 @@ newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst) -- Instantiate with META type variables -tcInstTyVars tyvars - = do { tc_tvs <- mapM tcInstTyVar tyvars - ; let tys = mkTyVarTys tc_tvs - ; return (tc_tvs, tys, zipTopTvSubst tyvars tys) } - -- Since the tyvars are freshly made, - -- they cannot possibly be captured by - -- any existing for-alls. Hence zipTopTvSubst - -tcInstTyVar :: TyVar -> TcM TcTyVar --- Make a new unification variable tyvar whose Name and Kind --- come from an existing TyVar -tcInstTyVar tyvar - = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi - ; let name = mkSystemName uniq (getOccName tyvar) - kind = tyVarKind tyvar - ; return (mkTcTyVar name kind (MetaTv TauTv ref)) } +tcInstTyVars tyvars = tcInstTyVarsX emptyTvSubst tyvars + -- emptyTvSubst has an empty in-scope set, but that's fine here + -- Since the tyvars are freshly made, they cannot possibly be + -- captured by any existing for-alls. + +tcInstTyVarsX :: TvSubst -> [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst) +tcInstTyVarsX subst tyvars = + do { (subst', tyvars') <- mapAccumLM tcInstTyVar subst tyvars + ; return (tyvars', mkTyVarTys tyvars', subst') } + +tcInstTyVar :: TvSubst -> TyVar -> TcM (TvSubst, TcTyVar) +-- Make a new unification variable tyvar whose Name and Kind come from +-- an existing TyVar. We substitute kind variables in the kind. +tcInstTyVar subst tyvar + = do { uniq <- newMetaUnique + ; ref <- newMutVar Flexi + ; let name = mkSystemName uniq (getOccName tyvar) + kind = substTy subst (tyVarKind tyvar) + new_tv = mkTcTyVar name kind (MetaTv TauTv ref) + ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) } \end{code} @@ -474,29 +528,37 @@ zonkTcType ty = zonkType zonkTcTyVar ty zonkTcTyVar :: TcTyVar -> TcM TcType -- Simply look through all Flexis zonkTcTyVar tv - = ASSERT2( isTcTyVar tv, ppr tv ) + = ASSERT2( isTcTyVar tv, ppr tv ) do case tcTyVarDetails tv of - SkolemTv {} -> return (TyVarTy tv) - RuntimeUnk {} -> return (TyVarTy tv) + SkolemTv {} -> zonk_kind_and_return + RuntimeUnk {} -> zonk_kind_and_return FlatSkol ty -> zonkTcType ty MetaTv _ ref -> do { cts <- readMutVar ref ; case cts of - Flexi -> return (TyVarTy tv) + Flexi -> zonk_kind_and_return Indirect ty -> zonkTcType ty } + where + zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv + ; return (TyVarTy z_tv) } + +zonkTyVarKind :: TyVar -> TcM TyVar +zonkTyVarKind tv = do { kind' <- zonkTcKind (tyVarKind tv) + ; return (setTyVarKind tv kind') } zonkTcTypeAndSubst :: TvSubst -> TcType -> TcM TcType -- Zonk, and simultaneously apply a non-necessarily-idempotent substitution zonkTcTypeAndSubst subst ty = zonkType zonk_tv ty where - zonk_tv tv - = case tcTyVarDetails tv of - SkolemTv {} -> return (TyVarTy tv) - RuntimeUnk {} -> return (TyVarTy tv) - FlatSkol ty -> zonkType zonk_tv ty - MetaTv _ ref -> do { cts <- readMutVar ref - ; case cts of - Flexi -> zonk_flexi tv - Indirect ty -> zonkType zonk_tv ty } + zonk_tv tv + = do { z_tv <- updateTyVarKindM zonkTcKind tv + ; case tcTyVarDetails tv of + SkolemTv {} -> return (TyVarTy z_tv) + RuntimeUnk {} -> return (TyVarTy z_tv) + FlatSkol ty -> zonkType zonk_tv ty + MetaTv _ ref -> do { cts <- readMutVar ref + ; case cts of + Flexi -> zonk_flexi z_tv + Indirect ty -> zonkType zonk_tv ty } } zonk_flexi tv = case lookupTyVar subst tv of Just ty -> zonkType zonk_tv ty @@ -516,8 +578,32 @@ zonkTcPredType = zonkTcType are used at the end of type checking \begin{code} -zonkQuantifiedTyVars :: [TcTyVar] -> TcM [TcTyVar] -zonkQuantifiedTyVars = mapM zonkQuantifiedTyVar +defaultKindVarToStar :: TcTyVar -> TcM () +-- We have a meta-kind: unify it with '*' +defaultKindVarToStar kv + = ASSERT ( isKiVar kv && isMetaTyVar kv ) + writeMetaTyVar kv liftedTypeKind + +zonkQuantifiedTyVars :: TcTyVarSet -> TcM [TcTyVar] +-- Precondition: a kind variable occurs before a type +-- variable mentioning it in its kind +zonkQuantifiedTyVars tyvars + = do { let (kvs, tvs) = partitionKiTyVars (varSetElems tyvars) + ; poly_kinds <- xoptM Opt_PolyKinds + ; if poly_kinds then + mapM zonkQuantifiedTyVar (kvs ++ tvs) + -- Because of the order, any kind variables + -- mentioned in the kinds of the type variables refer to + -- the now-quantified versions + else + -- In the non-PolyKinds case, default the kind variables + -- to *, and zonk the tyvars as usual. Notice that this + -- may make zonkQuantifiedTyVars return a shorter list + -- than it was passed, but that's ok + do { let (meta_kvs, skolem_kvs) = partition isMetaTyVar kvs + ; WARN ( not (null skolem_kvs), ppr skolem_kvs ) + mapM_ defaultKindVarToStar meta_kvs + ; mapM zonkQuantifiedTyVar (skolem_kvs ++ tvs) } } zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar -- The quantified type variables often include meta type variables @@ -529,11 +615,13 @@ zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar -- the immutable version. -- -- We leave skolem TyVars alone; they are immutable. +-- +-- This function is called on both kind and type variables, +-- but kind variables *only* if PolyKinds is on. zonkQuantifiedTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of - SkolemTv {} -> WARN( True, ppr tv ) -- Dec10: Can this really happen? - do { kind <- zonkTcType (tyVarKind tv) + SkolemTv {} -> do { kind <- zonkTcKind (tyVarKind tv) ; return $ setTyVarKind tv kind } -- It might be a skolem type variable, -- for example from a user type signature @@ -561,11 +649,13 @@ skolemiseUnboundMetaTyVar tv details do { span <- getSrcSpanM -- Get the location from "here" -- ie where we are generalising ; uniq <- newUnique -- Remove it from TcMetaTyVar unique land - ; let final_kind = defaultKind (tyVarKind tv) + ; kind <- zonkTcKind (tyVarKind tv) + ; let final_kind = defaultKind kind final_name = mkInternalName uniq (getOccName tv) span final_tv = mkTcTyVar final_name final_kind details - ; writeMetaTyVar tv (mkTyVarTy final_tv) - ; return final_tv } + + ; writeMetaTyVar tv (mkTyVarTy final_tv) + ; return final_tv } \end{code} \begin{code} @@ -672,7 +762,7 @@ leads to problems. Consider this program from the regression test suite: It leads to the deferral of an equality (wrapped in an implication constraint) - forall a. (String -> String -> String) ~ a + forall a. () => ((String -> String -> String) ~ a) which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck). In the meantime `a' is zonked and quantified to form `evalRHS's signature. @@ -704,6 +794,9 @@ simplifier knows how to deal with. -- For tyvars bound at a for-all, zonkType zonks them to an immutable -- type variable and zonks the kind too +zonkKind :: (TcTyVar -> TcM Kind) -> TcKind -> TcM Kind +zonkKind = zonkType + zonkType :: (TcTyVar -> TcM Type) -- What to do with TcTyVars -> TcType -> TcM Type zonkType zonk_tc_tyvar ty @@ -725,26 +818,13 @@ zonkType zonk_tc_tyvar ty -- The two interesting cases! go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar - | otherwise = return (TyVarTy tyvar) + | otherwise = TyVarTy <$> updateTyVarKindM zonkTcKind tyvar -- Ordinary (non Tc) tyvars occur inside quantified types go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do ty' <- go ty - tyvar' <- return tyvar + tyvar' <- updateTyVarKindM zonkTcKind tyvar return (ForAllTy tyvar' ty') - -mkZonkTcTyVar :: (TcTyVar -> TcM Type) -- What to do for an *mutable Flexi* var - -> TcTyVar -> TcM TcType -mkZonkTcTyVar unbound_var_fn tyvar - = ASSERT( isTcTyVar tyvar ) - case tcTyVarDetails tyvar of - SkolemTv {} -> return (TyVarTy tyvar) - RuntimeUnk {} -> return (TyVarTy tyvar) - FlatSkol ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty - MetaTv _ ref -> do { cts <- readMutVar ref - ; case cts of - Flexi -> unbound_var_fn tyvar - Indirect ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty } \end{code} @@ -756,21 +836,21 @@ mkZonkTcTyVar unbound_var_fn tyvar %************************************************************************ \begin{code} -readKindVar :: KindVar -> TcM (MetaDetails) -writeKindVar :: KindVar -> TcKind -> TcM () -readKindVar kv = readMutVar (kindVarRef kv) -writeKindVar kv val = writeMutVar (kindVarRef kv) (Indirect val) +compatKindTcM :: Kind -> Kind -> TcM Bool +compatKindTcM k1 k2 + = do { k1' <- zonkTcKind k1 + ; k2' <- zonkTcKind k2 + ; return $ k1' `isSubKind` k2' || k2' `isSubKind` k1' } + +isSubKindTcM :: Kind -> Kind -> TcM Bool +isSubKindTcM k1 k2 + = do { k1' <- zonkTcKind k1 + ; k2' <- zonkTcKind k2 + ; return $ k1' `isSubKind` k2' } ------------- zonkTcKind :: TcKind -> TcM TcKind zonkTcKind k = zonkTcType k - -------------- -zonkTcKindToKind :: TcKind -> TcM Kind --- When zonking a TcKind to a kind, we need to instantiate kind variables, --- Haskell specifies that * is to be used, so we follow that. -zonkTcKindToKind k - = zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind)) k \end{code} %************************************************************************ @@ -827,9 +907,6 @@ checkValidType ctxt ty = do LamPatSigCtxt -> gen_rank 0 BindPatSigCtxt -> gen_rank 0 TySynCtxt _ -> gen_rank 0 - GenPatCtxt -> gen_rank 1 - -- This one is a bit of a hack - -- See the forall-wrapping in TcClassDcl.mkGenericInstance ExprSigCtxt -> gen_rank 1 FunSigCtxt _ -> gen_rank 1 @@ -843,8 +920,8 @@ checkValidType ctxt ty = do SpecInstCtxt -> gen_rank 1 ThBrackCtxt -> gen_rank 1 GhciCtxt -> ArbitraryRank - GenSigCtxt -> panic "checkValidType" - -- Can't happen; GenSigCtxt not used for *user* sigs + _ -> panic "checkValidType" + -- Can't happen; not used for *user* sigs actual_kind = typeKind ty @@ -852,11 +929,10 @@ checkValidType ctxt ty = do TySynCtxt _ -> True -- Any kind will do ThBrackCtxt -> True -- ditto GhciCtxt -> True -- ditto - ResSigCtxt -> isSubOpenTypeKind actual_kind - ExprSigCtxt -> isSubOpenTypeKind actual_kind - GenPatCtxt -> isLiftedTypeKind actual_kind + ResSigCtxt -> tcIsSubOpenTypeKind actual_kind + ExprSigCtxt -> tcIsSubOpenTypeKind actual_kind ForSigCtxt _ -> isLiftedTypeKind actual_kind - _ -> isSubArgTypeKind actual_kind + _ -> tcIsSubArgTypeKind actual_kind ubx_tup | not unboxed = UT_NotOk @@ -871,8 +947,9 @@ checkValidType ctxt ty = do check_type rank ubx_tup ty -- Check that the thing has kind Type, and is lifted if necessary - -- Do this second, becuase we can't usefully take the kind of an + -- Do this second, because we can't usefully take the kind of an -- ill-formed type such as (a~Int) + traceTc "checkValidType kind_ok ctxt" (ppr kind_ok $$ pprUserTypeCtxt ctxt) checkTc kind_ok (kindErr actual_kind) traceTc "checkValidType done" (ppr ty) @@ -904,9 +981,11 @@ data UbxTupFlag = UT_Ok | UT_NotOk -- The "Ok" version means "ok if UnboxedTuples is on" ---------------------------------------- -check_mono_type :: Rank -> Type -> TcM () -- No foralls anywhere +check_mono_type :: Rank -> KindOrType -> TcM () -- No foralls anywhere -- No unlifted types of any kind check_mono_type rank ty + | isKind ty = return () -- IA0_NOTE: Do we need to check kinds? + | otherwise = do { check_type rank UT_NotOk ty ; checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty) } @@ -988,7 +1067,7 @@ check_type rank ubx_tup ty@(TyConApp tc tys) check_type _ _ ty = pprPanic "check_type" (ppr ty) ---------------------------------------- -check_arg_type :: Rank -> Type -> TcM () +check_arg_type :: Rank -> KindOrType -> TcM () -- The sort of type that can instantiate a type variable, -- or be the argument of a type constructor. -- Not an unboxed tuple, but now *can* be a forall (since impredicativity) @@ -1007,7 +1086,9 @@ check_arg_type :: Rank -> Type -> TcM () -- But not in user code. -- Anyway, they are dealt with by a special case in check_tau_type -check_arg_type rank ty +check_arg_type rank ty + | isKind ty = return () -- IA0_NOTE: Do we need to check a kind? + | otherwise = do { impred <- xoptM Opt_ImpredicativeTypes ; let rank' = case rank of -- Predictive => must be monotype MustBeMonoType -> MustBeMonoType -- Monotype, regardless @@ -1077,39 +1158,12 @@ If we do both, we get exponential behaviour!! %************************************************************************ \begin{code} --- Enumerate the contexts in which a "source type", <S>, can occur --- Eq a --- or ?x::Int --- or r <: {x::Int} --- or (N a) where N is a newtype - -data SourceTyCtxt - = ClassSCCtxt Name -- Superclasses of clas - -- class <S> => C a where ... - | SigmaCtxt -- Theta part of a normal for-all type - -- f :: <S> => a -> a - | DataTyCtxt Name -- Theta part of a data decl - -- data <S> => T a = MkT a - | TypeCtxt -- Source type in an ordinary type - -- f :: N a -> N a - | InstThetaCtxt -- Context of an instance decl - -- instance <S> => C [a] where ... - -pprSourceTyCtxt :: SourceTyCtxt -> SDoc -pprSourceTyCtxt (ClassSCCtxt c) = ptext (sLit "the super-classes of class") <+> quotes (ppr c) -pprSourceTyCtxt SigmaCtxt = ptext (sLit "the context of a polymorphic type") -pprSourceTyCtxt (DataTyCtxt tc) = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc) -pprSourceTyCtxt InstThetaCtxt = ptext (sLit "the context of an instance declaration") -pprSourceTyCtxt TypeCtxt = ptext (sLit "the context of a type") -\end{code} - -\begin{code} -checkValidTheta :: SourceTyCtxt -> ThetaType -> TcM () +checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM () checkValidTheta ctxt theta = addErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta) ------------------------- -check_valid_theta :: SourceTyCtxt -> [PredType] -> TcM () +check_valid_theta :: UserTypeCtxt -> [PredType] -> TcM () check_valid_theta _ [] = return () check_valid_theta ctxt theta = do @@ -1120,10 +1174,10 @@ check_valid_theta ctxt theta = do (_,dups) = removeDups cmpPred theta ------------------------- -check_pred_ty :: DynFlags -> SourceTyCtxt -> PredType -> TcM () +check_pred_ty :: DynFlags -> UserTypeCtxt -> PredType -> TcM () check_pred_ty dflags ctxt pred = check_pred_ty' dflags ctxt (shallowPredTypePredTree pred) -check_pred_ty' :: DynFlags -> SourceTyCtxt -> PredTree -> TcM () +check_pred_ty' :: DynFlags -> UserTypeCtxt -> PredTree -> TcM () check_pred_ty' dflags ctxt (ClassPred cls tys) = do { -- Class predicates are valid in all contexts ; checkTc (arity == n_tys) arity_err @@ -1199,22 +1253,55 @@ check_pred_ty' dflags ctxt (IrredPred pred) | xopt Opt_UndecidableInstances dflags -> return () | otherwise -> do -- Make sure it is OK to have an irred pred in this context - checkTc (case ctxt of ClassSCCtxt _ -> False; InstThetaCtxt -> False; _ -> True) + checkTc (case ctxt of ClassSCCtxt _ -> False; InstDeclCtxt -> False; _ -> True) (predIrredBadCtxtErr pred) ------------------------- -check_class_pred_tys :: DynFlags -> SourceTyCtxt -> [Type] -> Bool -check_class_pred_tys dflags ctxt tys +check_class_pred_tys :: DynFlags -> UserTypeCtxt -> [KindOrType] -> Bool +check_class_pred_tys dflags ctxt kts = case ctxt of - TypeCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine - InstThetaCtxt -> flexible_contexts || undecidable_ok || all tcIsTyVarTy tys + SpecInstCtxt -> True -- {-# SPECIALISE instance Eq (T Int) #-} is fine + InstDeclCtxt -> flexible_contexts || undecidable_ok || all tcIsTyVarTy tys -- Further checks on head and theta in -- checkInstTermination _ -> flexible_contexts || all tyvar_head tys where + (_, tys) = span isKind kts -- see Note [Kind polymorphic type classes] flexible_contexts = xopt Opt_FlexibleContexts dflags undecidable_ok = xopt Opt_UndecidableInstances dflags +{- +Note [Kind polymorphic type classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +class C f where + empty :: f a +-- C :: forall k. k -> Constraint +-- empty :: forall (a :: k). f a + +MultiParam: +~~~~~~~~~~~ + +instance C Maybe where + empty = Nothing + +The dictionary gets type [C * Maybe] even if it's not a MultiParam +type class. + +Flexible: +~~~~~~~~~ + +data D a = D +-- D :: forall k. k -> * + +instance C D where + empty = D + +The dictionary gets type [C * (D *)]. IA0_TODO it should be +generalized actually. + +-} + ------------------------- tyvar_head :: Type -> Bool tyvar_head ty -- Haskell 98 allows predicates of form @@ -1337,10 +1424,10 @@ so we can take their type variables into account as part of the \begin{code} -checkThetaCtxt :: SourceTyCtxt -> ThetaType -> SDoc +checkThetaCtxt :: UserTypeCtxt -> ThetaType -> SDoc checkThetaCtxt ctxt theta = vcat [ptext (sLit "In the context:") <+> pprTheta theta, - ptext (sLit "While checking") <+> pprSourceTyCtxt ctxt ] + ptext (sLit "While checking") <+> pprUserTypeCtxt ctxt ] eqPredTyErr, predTyVarErr, predTupleErr, predIrredErr, predIrredBadCtxtErr :: PredType -> SDoc eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprType pred @@ -1385,20 +1472,23 @@ compiled elsewhere). In these cases, we let them go through anyway. We can also have instances for functions: @instance Foo (a -> b) ...@. \begin{code} -checkValidInstHead :: Class -> [Type] -> TcM () -checkValidInstHead clas tys +checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () +checkValidInstHead ctxt clas tys = do { dflags <- getDOpts - -- If GlasgowExts then check at least one isn't a type variable - ; checkTc (xopt Opt_TypeSynonymInstances dflags || - all tcInstHeadTyNotSynonym tys) + -- Check language restrictions; + -- but not for SPECIALISE isntance pragmas + ; unless spec_inst_prag $ + do { checkTc (xopt Opt_TypeSynonymInstances dflags || + all tcInstHeadTyNotSynonym tys) (instTypeErr pp_pred head_type_synonym_msg) - ; checkTc (xopt Opt_FlexibleInstances dflags || - all tcInstHeadTyAppAllTyVars tys) + ; checkTc (xopt Opt_FlexibleInstances dflags || + all tcInstHeadTyAppAllTyVars tys) (instTypeErr pp_pred head_type_args_tyvars_msg) - ; checkTc (xopt Opt_MultiParamTypeClasses dflags || - isSingleton tys) - (instTypeErr pp_pred head_one_type_msg) + ; checkTc (xopt Opt_MultiParamTypeClasses dflags || + isSingleton (dropWhile isKind tys)) -- IA0_NOTE: only count type arguments + (instTypeErr pp_pred head_one_type_msg) } + -- May not contain type family applications ; mapM_ checkTyFamFreeness tys @@ -1411,6 +1501,8 @@ checkValidInstHead clas tys } where + spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False } + pp_pred = pprClassPred clas tys head_type_synonym_msg = parens ( text "All instance types must be of the form (T t1 ... tn)" $$ @@ -1463,12 +1555,12 @@ validDerivPred tv_set ty = case getClassPredTys_maybe ty of %************************************************************************ \begin{code} -checkValidInstance :: LHsType Name -> [TyVar] -> ThetaType +checkValidInstance :: UserTypeCtxt -> LHsType Name -> [TyVar] -> ThetaType -> Class -> [TcType] -> TcM () -checkValidInstance hs_type tyvars theta clas inst_tys +checkValidInstance ctxt hs_type tyvars theta clas inst_tys = setSrcSpan (getLoc hs_type) $ - do { setSrcSpan head_loc (checkValidInstHead clas inst_tys) - ; checkValidTheta InstThetaCtxt theta + do { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys) + ; checkValidTheta ctxt theta ; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys) -- Check that instance inference will terminate (if we care) @@ -1641,18 +1733,6 @@ fvTypes :: [Type] -> [TyVar] fvTypes tys = concat (map fvType tys) ------------------- -sizePred :: PredType -> Int --- Size of a predicate: the number of variables and constructors --- See Note [Paterson conditions on PredTypes] -sizePred ty = go (predTypePredTree ty) - where - go (ClassPred _ tys') = sizeTypes tys' - go (IPPred {}) = 0 - go (EqPred {}) = 0 - go (TuplePred ts) = maximum (0:map go ts) - go (IrredPred ty) = sizeType ty - -------------------- sizeType :: Type -> Int -- Size of a type: the number of variables and constructors sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty @@ -1663,7 +1743,24 @@ sizeType (AppTy fun arg) = sizeType fun + sizeType arg sizeType (ForAllTy _ ty) = sizeType ty sizeTypes :: [Type] -> Int -sizeTypes xs = sum (map sizeType xs) +-- IA0_NOTE: Avoid kinds. +sizeTypes xs = sum (map sizeType tys) + where tys = filter (not . isKind) xs + +-- Size of a predicate +-- +-- We are considering whether *class* constraints terminate +-- Once we get into an implicit parameter or equality we +-- can't get back to a class constraint, so it's safe +-- to say "size 0". See Trac #4200. +sizePred :: PredType -> Int +sizePred ty = go (predTypePredTree ty) + where + go (ClassPred _ tys') = sizeTypes tys' + go (IPPred {}) = 0 + go (EqPred {}) = 0 + go (TuplePred ts) = sum (map go ts) + go (IrredPred ty) = sizeType ty \end{code} Note [Paterson conditions on PredTypes] diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index e99d2656fc..4204564811 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -673,6 +673,8 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside ; checkExistentials ex_tvs penv ; ex_tvs' <- tcInstSuperSkolTyVars ex_tvs +-- JPM: call the X version, with initial subt (univ_tvs -> ctxt_res_tys) +-- return tenv -- Get location from monad, not from ex_tvs ; let pat_ty' = mkTyConApp tycon ctxt_res_tys diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 0cfa60f997..48f3cf8fd7 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -333,7 +333,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- any mutually recursive types are done right -- Just discard the auxiliary bindings; they are generated -- only for Haskell source code, and should already be in Core - (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ; + tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ; dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ; setGblEnv tcg_env $ do { @@ -357,7 +357,6 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_deps = noDependencies, -- ?? mg_exports = my_exports, mg_tcs = tcg_tcs tcg_env, - mg_clss = tcg_clss tcg_env, mg_insts = tcg_insts tcg_env, mg_fam_insts = tcg_fam_insts tcg_env, mg_inst_env = tcg_inst_env tcg_env, @@ -538,8 +537,8 @@ tcRnHsBootDecls decls -- Typecheck type/class decls ; traceTc "Tc2" empty - ; (tcg_env, aux_binds) - <- tcTyAndClassDecls emptyModDetails tycl_decls + ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls + ; let aux_binds = mkRecSelBinds [tc | ATyCon tc <- nameEnvElts (tcg_type_env tcg_env)] ; setGblEnv tcg_env $ do { -- Typecheck instance decls @@ -746,7 +745,8 @@ checkBootTyCon tc1 tc2 = checkBootTyCon tc1 tc2 && eqListBy eqATDef def_ats1 def_ats2 - eqATDef (ATD tvs1 ty_pats1 ty1) (ATD tvs2 ty_pats2 ty2) + -- Ignore the location of the defaults + eqATDef (ATD tvs1 ty_pats1 ty1 _loc1) (ATD tvs2 ty_pats2 ty2 _loc2) = eqListBy same_kind tvs1 tvs2 && eqListBy (eqTypeX env) ty_pats1 ty_pats2 && eqTypeX env ty1 ty2 @@ -887,9 +887,10 @@ tcTopSrcDecls boot_details -- The latter come in via tycl_decls traceTc "Tc2" empty ; - (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ; + tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; + let { aux_binds = mkRecSelBinds [tc | tc <- tcg_tcs tcg_env] } ; -- If there are any errors, tcTyAndClassDecls fails here - + setGblEnv tcg_env $ do { -- Source-language instances, including derivings, @@ -963,6 +964,7 @@ tcTopSrcDecls boot_details , tcg_vects = tcg_vects tcg_env ++ vects , tcg_anns = tcg_anns tcg_env ++ annotations , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; + return (tcg_env', tcl_env) }}}}}} \end{code} @@ -1446,7 +1448,7 @@ tcRnType hsc_env ictxt normalise rdr_type = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { - rn_type <- rnLHsType doc rdr_type ; + rn_type <- rnLHsType GHCiCtx rdr_type ; failIfErrsM ; -- Now kind-check the type @@ -1462,8 +1464,6 @@ tcRnType hsc_env ictxt normalise rdr_type return (ty', typeKind ty) } - where - doc = ptext (sLit "In GHCi input") \end{code} @@ -1727,10 +1727,8 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, pprModGuts :: ModGuts -> SDoc pprModGuts (ModGuts { mg_tcs = tcs - , mg_clss = clss , mg_rules = rules }) - = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs - ++ map (ATyCon . classTyCon) clss)), + = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs)), ppr_rules rules ] ppr_types :: [Instance] -> TypeEnv -> SDoc diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index a52d8ba9d6..d10d451642 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -124,7 +124,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_warns = NoWarnings, tcg_anns = [], tcg_tcs = [], - tcg_clss = [], tcg_insts = [], tcg_fam_insts = [], tcg_rules = [], diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 1ec310cd1e..dc2e55ff8b 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -296,8 +296,7 @@ data TcGblEnv tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids tcg_warns :: Warnings, -- ...Warnings and deprecations tcg_anns :: [Annotation], -- ...Annotations - tcg_tcs :: [TyCon], -- ...TyCons - tcg_clss :: [Class], -- ...Classes + tcg_tcs :: [TyCon], -- ...TyCons and Classes tcg_insts :: [Instance], -- ...Instances tcg_fam_insts :: [FamInst], -- ...Family instances tcg_rules :: [LRuleDecl Id], -- ...Rules @@ -559,8 +558,32 @@ 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 - -- tycons and clases in this recursive group + | AThing TcKind -- 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 + -- Note [Type checking recursive type and class declarations] + + | ANothing -- see Note [ANothing] + +{- +Note [ANothing] +~~~~~~~~~~~~~~~ + +We don't want to allow promotion in a strongly connected component +when kind checking. + +Consider: + data T f = K (f (K Any)) + +When kind checking the `data T' declaration the local env contains the +mappings: + T -> AThing <some initial kind> + K -> ANothing + +ANothing is only used for DataCons, and only used during type checking +in tcTyClGroup. +-} + instance Outputable TcTyThing where -- Debugging only ppr (AGlobal g) = pprTyThing g @@ -571,12 +594,14 @@ instance Outputable TcTyThing where -- Debugging only <+> ppr (tct_level elt)) ppr (ATyVar tv _) = text "Type variable" <+> quotes (ppr tv) ppr (AThing k) = text "AThing" <+> ppr k + ppr ANothing = text "ANothing" 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 ANothing = ptext (sLit "Opaque thing") \end{code} Note [Bindings with closed types] @@ -587,7 +612,7 @@ Consider in ... Can we generalise 'g' under the OutsideIn algorithm? Yes, -becuase all g's free variables are top-level; that is they themselves +because all g's free variables are top-level; that is they themselves have no free type variables, and it is the type variables in the environment that makes things tricky for OutsideIn generalisation. diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index 9aae216ab5..40e05027be 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -25,7 +25,6 @@ import TcExpr import TcEnv import Id import Name -import VarSet import SrcLoc import Outputable import FastString @@ -60,7 +59,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- Note [Typechecking rules] ; vars <- tcRuleBndrs hs_bndrs ; let (id_bndrs, tv_bndrs) = partition isId vars - ; (lhs', lhs_lie, rhs', rhs_lie, rule_ty) + ; (lhs', lhs_lie, rhs', rhs_lie, _rule_ty) <- tcExtendTyVarEnv tv_bndrs $ tcExtendIdEnv id_bndrs $ do { ((lhs', rule_ty), lhs_lie) <- captureConstraints (tcInferRho lhs) @@ -91,6 +90,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- during zonking (see TcHsSyn.zonkRule) ; let tpl_ids = lhs_dicts ++ id_bndrs +{- forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids) -- Now figure out what to quantify over @@ -101,10 +101,13 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) `minusVarSet` gbl_tvs `delVarSetList` tv_bndrs ; qtvs <- zonkQuantifiedTyVars (varSetElems extra_bound_tvs) + ; let all_tvs = tv_bndrs ++ qtvs + ; (kvs, _kinds) <- kindGeneralizeKinds $ map tyVarKind all_tvs +-} -- The tv_bndrs are already skolems, so no need to zonk them ; return (HsRule name act - (map (RuleBndr . noLoc) (tv_bndrs ++ qtvs ++ tpl_ids)) -- yuk + (map (RuleBndr . noLoc) (tv_bndrs ++ tpl_ids)) (mkHsDictLet lhs_ev_binds lhs') fv_lhs (mkHsDictLet rhs_ev_binds rhs') fv_rhs) } diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index e7d2e49604..3114ba4757 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -64,7 +64,7 @@ module TcSMonad ( instDFunConstraints, newFlexiTcSTy, instFlexiTcS, - compatKind, + compatKind, compatKindTcS, isSubKindTcS, unifyKindTcS, TcsUntouchables, isTouchableMetaTyVar, @@ -96,6 +96,7 @@ import qualified TcRnMonad as TcM import qualified TcMType as TcM import qualified TcEnv as TcM ( checkWellStaged, topIdLvl, tcGetDefaultTys ) +import {-# SOURCE #-} qualified TcUnify as TcM ( unifyKindEq, mkKindErrorCtxt ) import Kind import TcType import DynFlags @@ -203,6 +204,21 @@ mkFrozenError fl ev = CFrozenErr { cc_id = ev, cc_flavor = fl } compatKind :: Kind -> Kind -> Bool compatKind k1 k2 = k1 `isSubKind` k2 || k2 `isSubKind` k1 +compatKindTcS :: Kind -> Kind -> TcS Bool +-- Because kind unification happens during constraint solving, we have +-- to make sure that two kinds are zonked before we compare them. +compatKindTcS k1 k2 = wrapTcS (TcM.compatKindTcM k1 k2) + +isSubKindTcS :: Kind -> Kind -> TcS Bool +isSubKindTcS k1 k2 = wrapTcS (TcM.isSubKindTcM k1 k2) + +unifyKindTcS :: Type -> Type -- Context + -> Kind -> Kind -- Corresponding kinds + -> TcS () +unifyKindTcS ty1 ty2 ki1 ki2 + = wrapTcS (TcM.addErrCtxtM ctxt (TcM.unifyKindEq ki1 ki2)) + where ctxt = TcM.mkKindErrorCtxt ty1 ki1 ty2 ki2 + deCanonicalise :: CanonicalCt -> FlavoredEvVar deCanonicalise ct = mkEvVarX (cc_id ct) (cc_flavor ct) diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index dc8c5f95f9..bd558829d6 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -28,7 +28,6 @@ import VarSet import VarEnv import Coercion import TypeRep - import Name import NameEnv ( emptyNameEnv ) import Bag @@ -210,6 +209,18 @@ Allow constraints which consist only of type variables, with no repeats. * * *********************************************************************************** +Note [Which variables to quantify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose the inferred type of a function is + T kappa (alpha:kappa) -> Int +where alpha is a type unification variable and + kappa is a kind unification variable +Then we want to quantify over *both* alpha and kappa. But notice that +kappa appears "at top level" of the type, as well as inside the kind +of alpha. So it should be fine to just look for the "top level" +kind/type variables of the type, without looking transitively into the +kinds of those type variables. + \begin{code} simplifyInfer :: Bool -> Bool -- Apply monomorphism restriction @@ -226,8 +237,10 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds | isEmptyWC wanteds = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked ; zonked_taus <- zonkTcTypes (map snd name_taus) - ; let tvs_to_quantify = get_tau_tvs zonked_taus `minusVarSet` gbl_tvs - ; qtvs <- zonkQuantifiedTyVars (varSetElems tvs_to_quantify) + ; let tvs_to_quantify = tyVarsOfTypes zonked_taus `minusVarSet` gbl_tvs + -- tvs_to_quantify can contain both kind and type vars + -- See Note [Which variables to quantify] + ; qtvs <- zonkQuantifiedTyVars tvs_to_quantify ; return (qtvs, [], False, emptyTcEvBinds) } | otherwise @@ -249,7 +262,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- Then split the constraints on the baisis of those tyvars -- to avoid unnecessarily simplifying a class constraint -- See Note [Avoid unecessary constraint simplification] - ; let zonked_tau_tvs = get_tau_tvs zonked_taus + ; let zonked_tau_tvs = tyVarsOfTypes zonked_taus proto_qtvs = growWanteds gbl_tvs zonked_wanteds $ zonked_tau_tvs `minusVarSet` gbl_tvs (perhaps_bound, surely_free) @@ -311,8 +324,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- they are also bound in ic_skols and we want them to be -- tidied uniformly - ; gloc <- getCtLoc skol_info - ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElems qtvs) + ; qtvs_to_return <- zonkQuantifiedTyVars qtvs -- Step 5 -- Minimize `bound' and emit an implication @@ -320,6 +332,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds ; ev_binds_var <- newTcEvBinds ; mapBagM_ (\(EvBind evar etrm) -> addTcEvBind ev_binds_var evar etrm) tc_binds0 ; lcl_env <- getLclTypeEnv + ; gloc <- getCtLoc skol_info ; let implic = Implic { ic_untch = NoUntouchables , ic_env = lcl_env , ic_skols = mkVarSet qtvs_to_return @@ -340,13 +353,6 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds ; return ( qtvs_to_return, minimal_bound_ev_vars , mr_bites, TcEvBinds ev_binds_var) } } - where - get_tau_tvs = tyVarsOfTypes -- I think this stuff is out of date -{- - get_tau_tvs | isTopLevel top_lvl = tyVarsOfTypes - | otherwise = exactTyVarsOfTypes - -- See Note [Silly type synonym] in TcType --} \end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 3cf36f693e..0b9c7bf81c 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -364,7 +364,7 @@ tcBracket brack res_ty ; return (noLoc (HsBracketOut brack pendings)) } tc_bracket :: ThStage -> HsBracket Name -> TcM TcType -tc_bracket outer_stage (VarBr name) -- Note [Quoting names] +tc_bracket outer_stage br@(VarBr _ name) -- Note [Quoting names] = do { thing <- tcLookup name ; case thing of AGlobal _ -> return () @@ -373,7 +373,7 @@ tc_bracket outer_stage (VarBr name) -- Note [Quoting names] -> keepAliveTc id | otherwise -> do { checkTc (thLevel outer_stage + 1 == bind_lvl) - (quotedNameStageErr name) } + (quotedNameStageErr br) } _ -> pprPanic "th_bracket" (ppr name) ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) @@ -410,9 +410,9 @@ tc_bracket _ (PatBr pat) tc_bracket _ (DecBrL _) = panic "tc_bracket: Unexpected DecBrL" -quotedNameStageErr :: Name -> SDoc -quotedNameStageErr v - = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v) +quotedNameStageErr :: HsBracket Name -> SDoc +quotedNameStageErr br + = sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br , ptext (sLit "must be used at the same stage at which is is bound")] \end{code} @@ -536,8 +536,8 @@ kcSpliceType splice@(HsSplice name hs_expr) fvs -- Here (h 4) :: Q Type -- but $(h 4) :: a i.e. any type, of any kind - ; kind <- newKindVar - ; return (HsSpliceTy splice fvs kind, kind) + ; kind <- newMetaKindVar + ; return (HsSpliceTy splice fvs kind, kind) }}} kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind) @@ -551,11 +551,11 @@ kcTopSpliceType expr -- Run the expression ; hs_ty2 <- runMetaT zonked_q_expr ; showSplice "type" expr (ppr hs_ty2) - + -- Rename it, but bale out if there are errors -- otherwise the type checker just gives more spurious errors - ; addErrCtxt (spliceResultDoc expr) $ do - { let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2 + ; addErrCtxt (spliceResultDoc expr) $ do + { let doc = SpliceTypeCtx hs_ty2 ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2) ; (ty4, kind) <- kcLHsType hs_ty3 ; return (unLoc ty4, kind) }} @@ -990,7 +990,7 @@ reifyInstances th_nm th_tys _ -> bale_out (ppr_th th_nm <+> ptext (sLit "is not a class or type constructor")) } where - doc = ptext (sLit "TcSplice.reifyInstances") + doc = ClassInstanceCtx bale_out msg = failWithTc msg tc_types :: TyCon -> [TH.Type] -> TcM [Type] @@ -1159,6 +1159,7 @@ reifyThing (ATyVar tv ty) ; return (TH.TyVarI (reifyName tv) ty2) } reifyThing (AThing {}) = panic "reifyThing AThing" +reifyThing ANothing = panic "reifyThing ANothing" ------------------------------ reifyAxiom :: CoAxiom -> TcM TH.Info diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index aaa311b8aa..47c134a198 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -19,7 +19,7 @@ module TcTyClsDecls ( -- Functions used by TcInstDcls to check -- data/type family instance declarations kcDataDecl, tcConDecls, dataDeclChecks, checkValidTyCon, - tcSynFamInstDecl, kcFamTyPats, + tcSynFamInstDecl, tcFamTyPats, wrongKindOfFamily, badATErr, wrongATArgErr ) where @@ -38,6 +38,7 @@ import TcMType import TcType import TysWiredIn ( unitTy ) import Type +import Kind import Class import TyCon import DataCon @@ -73,80 +74,117 @@ import Data.List %* * %************************************************************************ +Note [Grouping of type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly +connected component of mutually dependent types and classes. We kind check and +type check each group separately to enhance kind polymorphism. Take the +following example: + + type Id a = a + data X = X (Id Int) + +If we were to kind check the two declarations together, we would give Id the +kind * -> *, since we apply it to an Int in the definition of X. But we can do +better than that, since Id really is kind polymorphic, and should get kind +forall (k::BOX). k -> k. Since it does not depend on anything else, it can be +kind-checked by itself, hence getting the most general kind. We then kind check +X, which works fine because we then know the polymorphic kind of Id, and simply +instantiate k to *. + \begin{code} -tcTyAndClassDecls :: ModDetails - -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order - -> TcM (TcGblEnv, -- Input env extended by types and classes - -- and their implicit Ids,DataCons - HsValBinds Name) -- Renamed bindings for record selectors +tcTyAndClassDecls :: ModDetails + -> [TyClGroup Name] -- Mutually-recursive groups in dependency order + -> TcM (TcGblEnv) -- Input env extended by types and classes + -- and their implicit Ids,DataCons -- Fails if there are any errors - tcTyAndClassDecls boot_details decls_s - = checkNoErrs $ -- The code recovers internally, but if anything gave rise to - -- an error we'd better stop now, to avoid a cascade - do { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s - -- Remove family instance decls altogether - -- They are dealt with by TcInstDcls - - ; tyclss <- fixM $ \ rec_tyclss -> - tcExtendRecEnv (zipRecTyClss tyclds_s rec_tyclss) $ - -- We must populate the environment with the loop-tied - -- T's right away (even before kind checking), because - -- the kind checker may "fault in" some type constructors - -- that recursively mention T - - do { -- Kind-check in dependency order - -- See Note [Kind checking for type and class decls] - kc_decls <- kcTyClDecls tyclds_s - - -- And now build the TyCons/Classes - ; let rec_flags = calcRecFlags boot_details rec_tyclss - ; concatMapM (tcTyClDecl rec_flags) kc_decls } - - ; traceTc "tcTyAndCl" (ppr tyclss) - + = checkNoErrs $ do -- The code recovers internally, but if anything gave rise to + -- an error we'd better stop now, to avoid a cascade + { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s + -- Remove family instance decls altogether + -- They are dealt with by TcInstDcls + ; fold_env tyclds_s } -- type check each group in dependency order folding the global env + where + fold_env :: [TyClGroup Name] -> TcM TcGblEnv + fold_env [] = getGblEnv + fold_env (tyclds:tyclds_s) + = do { env <- tcTyClGroup boot_details tyclds + ; setGblEnv env $ fold_env tyclds_s } + -- remaining groups are typecheck in the extended global env + +tcTyClGroup :: ModDetails -> TyClGroup Name -> TcM TcGblEnv +-- Typecheck one strongly-connected component of type and class decls +tcTyClGroup boot_details tyclds + = do { -- Step 1: kind-check this group and returns the final + -- (possibly-polymorphic) kind of each TyCon and Class + -- See Note [Kind checking for type and class decls] + names_w_poly_kinds <- kcTyClGroup tyclds + ; traceTc "tcTyAndCl generalized kinds" (ppr names_w_poly_kinds) + + -- Step 2: type-check all groups together, returning + -- the final TyCons and Classes + ; tyclss <- fixM $ \ rec_tyclss -> do + { let rec_flags = calcRecFlags boot_details rec_tyclss + + -- Populate environment with knot-tied ATyCon for TyCons + -- NB: if the decls mention any ill-staged data cons + -- (see Note [ANothing] in typecheck/TcRnTypes.lhs) we + -- will have failed already in kcTyClGroup, so no worries here + ; tcExtendRecEnv (zipRecTyClss tyclds rec_tyclss) $ + + -- 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 $ + + -- Kind and type check declarations for this group + concatMapM (tcTyClDecl rec_flags) tyclds } + + -- Step 3: Perform the validity chebck + -- We can do this now because we are done with the recursive knot + -- Do it before Step 4 (adding implicit things) because the latter + -- expects well-formed TyCons ; tcExtendGlobalEnv tyclss $ do - { -- Perform the validity check - -- We can do this now because we are done with the recursive knot - traceTc "ready for validity check" empty - ; mapM_ (addLocM checkValidTyCl) (concat tyclds_s) - ; traceTc "done" empty - - -- Add the implicit things; - -- we want them in the environment because - -- they may be mentioned in interface files - -- NB: All associated types and their implicit things will be added a - -- second time here. This doesn't matter as the definitions are - -- the same. - ; let { implicit_things = concatMap implicitTyThings tyclss - ; rec_sel_binds = mkRecSelBinds [tc | ATyCon tc <- tyclss] - ; dm_ids = mkDefaultMethodIds tyclss } - - ; tcg_env <- tcExtendGlobalEnvImplicit implicit_things $ - tcExtendGlobalValEnv dm_ids $ - getGblEnv - - ; return (tcg_env, rec_sel_binds) } } - -zipRecTyClss :: [[LTyClDecl Name]] + { traceTc "Starting validity check" (ppr tyclss) + ; mapM_ (addLocM checkValidTyCl) tyclds + + -- Step 4: Add the implicit things; + -- we want them in the environment because + -- they may be mentioned in interface files + ; let implicit_things = concatMap implicitTyThings tyclss + dm_ids = mkDefaultMethodIds tyclss + ; tcExtendGlobalEnvImplicit implicit_things $ + tcExtendGlobalValEnv dm_ids $ + getGblEnv } } + +zipRecTyClss :: TyClGroup Name -> [TyThing] -- Knot-tied -> [(Name,TyThing)] -- Build a name-TyThing mapping for the things bound by decls -- being careful not to look at the [TyThing] -- The TyThings in the result list must have a visible ATyCon, -- because typechecking types (in, say, tcTyClDecl) looks at this outer constructor -zipRecTyClss decls_s rec_things - = [ get decl | decls <- decls_s, L _ decl <- flattenATs decls ] +zipRecTyClss decls rec_things + = [ (name, ATyCon (get name)) + | name <- tyClsBinders decls ] where rec_type_env :: TypeEnv rec_type_env = mkTypeEnv rec_things - get :: TyClDecl Name -> (Name, TyThing) - get decl = (name, ATyCon tc) - where - name = tcdName decl - Just (ATyCon tc) = lookupTypeEnv rec_type_env name + get name = case lookupTypeEnv rec_type_env name of + Just (ATyCon tc) -> tc + other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other) + +tyClsBinders :: TyClGroup Name -> [Name] +-- Just the tycon and class binders of a group (not the data constructors) +tyClsBinders decls + = concatMap get decls + where + get (L _ (ClassDecl { tcdLName = L _ n, tcdATs = ats })) = n : tyClsBinders ats + get (L _ d) = [tcdName d] \end{code} @@ -206,67 +244,90 @@ The kind of a type family is solely determinded by its kind signature; hence, only kind signatures participate in the construction of the initial kind environment (as constructed by `getInitialKind'). In fact, we ignore instances of families altogether in the following. However, we need to -include the kinds of associated families into the construction of the +include the kinds of *associated* families into the construction of the initial kind environment. (This is handled by `allDecls'). \begin{code} -kcTyClDecls :: [[LTyClDecl Name]] -> TcM [LTyClDecl Name] -kcTyClDecls [] = return [] -kcTyClDecls (decls : decls_s) = do { (tcl_env, kc_decls1) <- kcTyClDecls1 decls - ; kc_decls2 <- setLclEnv tcl_env (kcTyClDecls decls_s) - ; return (kc_decls1 ++ kc_decls2) } - -kcTyClDecls1 :: [LTyClDecl Name] -> TcM (TcLclEnv, [LTyClDecl Name]) -kcTyClDecls1 decls - = do { -- Omit instances of type families; they are handled together - -- with the *heads* of class instances - ; let (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls - alg_at_decls = flattenATs alg_decls - - ; mod <- getModule - ; traceTc "tcTyAndCl" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls)) - - -- Kind checking; see Note [Kind checking for type and class decls] - ; alg_kinds <- mapM getInitialKind alg_at_decls - ; tcExtendKindEnv alg_kinds $ do - - { (kc_syn_decls, tcl_env) <- kcSynDecls (calcSynCycles syn_decls) - +kcTyClGroup :: TyClGroup Name -> TcM [(Name,Kind)] +-- Kind check this group, kind generalize, and return the resulting local env +-- See Note [Kind checking for type and class decls] +kcTyClGroup decls + = do { mod <- getModule + ; traceTc "kcTyClGroup" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls)) + + -- Kind checking; + -- 1. Bind kind variables for non-synonyms + -- 2. Kind-check synonyms, and bind kinds of those synonyms + -- 3. Kind-check non-synonyms + -- 4. Generalise the inferred kinds + -- See Note [Kind checking for type and class decls] + + -- Step 1: Bind kind variables for non-synonyms + ; let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls + ; initial_kinds <- concatMapM getInitialKinds non_syn_decls + ; tcExtendTcTyThingEnv initial_kinds $ do + + -- Step 2: kind-check the synonyms, and extend envt + { tcl_env <- kcSynDecls (calcSynCycles syn_decls) ; setLclEnv tcl_env $ do - { kc_alg_decls <- mapM (wrapLocM kcTyClDecl) alg_decls - - -- Kind checking done for this group, so zonk the kind variables - -- See Note [Kind checking for type and class decls] - ; mapM_ (zonkTcKindToKind . snd) alg_kinds - ; return (tcl_env, kc_syn_decls ++ kc_alg_decls) } } } + -- Step 3: kind-check the synonyms + { mapM_ (wrapLocM kcTyClDecl) non_syn_decls + + -- Step 4: generalisation + -- Kind checking done for this group + -- Now we have to kind generalize the flexis + ; mapM generalise (tyClsBinders decls) }}} -flattenATs :: [LTyClDecl Name] -> [LTyClDecl Name] -flattenATs decls = concatMap flatten decls where - flatten decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats - flatten decl = [decl] - -getInitialKind :: LTyClDecl Name -> TcM (Name, TcKind) --- Only for data type, class, and indexed type declarations --- Get as much info as possible from the data, class, or indexed type decl, --- so as to maximise usefulness of error messages -getInitialKind (L _ decl) + generalise :: Name -> TcM (Name, Kind) + generalise name + = do { traceTc "Generalise type of" (ppr name) + ; thing <- tcLookup name + ; let kc_kind = case thing of + AThing k -> k + _ -> pprPanic "kcTyClGroup" (ppr thing) + ; (kvs, kc_kind') <- kindGeneralizeKind kc_kind + ; return (name, mkForAllTys kvs kc_kind') } + +getInitialKinds :: LTyClDecl Name -> TcM [(Name, TcTyThing)] +-- Allocate a fresh kind variable for each TyCon and Class +-- For each tycon, return (tc, AThing k) +-- where k is the kind of tc, derived from the LHS +-- of the definition (and probably including +-- kind unification variables) +-- Example: data T a b = ... +-- return (T, kv1 -> kv2 -> *) +-- +-- ALSO for each datacon, return (dc, ANothing) +-- See Note [ANothing] in TcRnTypes + +getInitialKinds (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) } + ; let main_pair = (tcdName decl, AThing (mkArrowKinds arg_kinds res_kind)) + ; inner_pairs <- get_inner_kinds decl + ; return (main_pair : inner_pairs) } where - mk_arg_kind (UserTyVar _ _) = newKindVar - mk_arg_kind (KindedTyVar _ kind) = return kind + mk_arg_kind (UserTyVar _ _) = newMetaKindVar + mk_arg_kind (KindedTyVar _ kind _) = scDsLHsKind kind - mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind - mk_res_kind (TyData { tcdKindSig = Just kind }) = return kind + mk_res_kind (TyFamily { tcdKind = Just kind }) = scDsLHsKind kind + mk_res_kind (TyData { tcdKindSig = Just kind }) = scDsLHsKind kind -- On GADT-style declarations we allow a kind signature -- data T :: *->* where { ... } mk_res_kind (ClassDecl {}) = return constraintKind mk_res_kind _ = return liftedTypeKind + get_inner_kinds :: TyClDecl Name -> TcM [(Name,TcTyThing)] + get_inner_kinds (TyData { tcdCons = cons }) + = return [ (unLoc (con_name con), ANothing) | L _ con <- cons ] + get_inner_kinds (ClassDecl { tcdATs = ats }) + = concatMapM getInitialKinds ats + get_inner_kinds _ + = return [] + kcLookupKind :: Located Name -> TcM Kind kcLookupKind nm = do tc_ty_thing <- tcLookupLocated nm @@ -277,55 +338,58 @@ kcLookupKind nm = do ---------------- -kcSynDecls :: [SCC (LTyClDecl Name)] - -> TcM ([LTyClDecl Name], -- Kind-annotated decls - TcLclEnv) -- Kind bindings -kcSynDecls [] - = do { tcl_env <- getLclEnv; return ([], tcl_env) } +kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM (TcLclEnv) -- Kind bindings +kcSynDecls [] = getLclEnv kcSynDecls (group : groups) - = do { (decl, nk) <- kcSynDecl group - ; (decls, tcl_env) <- tcExtendKindEnv [nk] (kcSynDecls groups) - ; return (decl:decls, tcl_env) } - + = do { nk <- kcSynDecl1 group + ; tcExtendKindEnv [nk] (kcSynDecls groups) } + ---------------- -kcSynDecl :: SCC (LTyClDecl Name) - -> TcM (LTyClDecl Name, -- Kind-annotated decls - (Name,TcKind)) -- Kind bindings -kcSynDecl (AcyclicSCC (L loc decl)) - = tcAddDeclCtxt decl $ - kcHsTyVars (tcdTyVars decl) (\ k_tvs -> - do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) +kcSynDecl1 :: SCC (LTyClDecl Name) + -> TcM (Name,TcKind) -- Kind bindings +kcSynDecl1 (AcyclicSCC (L _ decl)) = kcSynDecl decl +kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM } + -- Fail here to avoid error cascade + -- of out-of-scope tycons + +kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind) +kcSynDecl decl -- Vanilla type synonyoms only, not family instances + = tcAddDeclCtxt decl $ + kcHsTyVars (tcdTyVars decl) $ \ k_tvs -> + do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) <+> brackets (ppr k_tvs)) - ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl) - ; traceTc "kcd2" (ppr (unLoc (tcdLName decl))) + ; (_, rhs_kind) <- kcLHsType (tcdSynRhs decl) + ; traceTc "kcd2" (ppr (tcdName decl)) ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs - ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }), - (unLoc (tcdLName decl), tc_kind)) }) - -kcSynDecl (CyclicSCC decls) - = do { recSynErr decls; failM } -- Fail here to avoid error cascade - -- of out-of-scope tycons + ; return (tcdName decl, tc_kind) } ------------------------------------------------------------------------ -kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name) - -- Not used for type synonyms (see kcSynDecl) +kcTyClDecl :: TyClDecl Name -> TcM () +-- This function is used solely for its side effect on kind variables + +kcTyClDecl (ForeignType {}) + = return () +kcTyClDecl decl@(TyFamily {}) + = kcFamilyDecl [] decl -- the empty list signals a toplevel decl kcTyClDecl decl@(TyData {}) = ASSERT( not . isFamInstDecl $ decl ) -- must not be a family instance - kcTyClDeclBody decl $ - kcDataDecl decl - -kcTyClDecl decl@(TyFamily {}) - = kcFamilyDecl [] decl -- the empty list signals a toplevel decl + kcTyClDeclBody decl $ \_ -> kcDataDecl decl -kcTyClDecl decl@(ClassDecl {}) - = kcClassDecl decl - -kcTyClDecl decl@(ForeignType {}) - = return decl +kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) + = kcTyClDeclBody decl $ \ tvs' -> + do { discardResult (kcHsContext ctxt) + ; mapM_ (wrapLocM (kcFamilyDecl tvs')) ats + ; mapM_ (wrapLocM kc_sig) sigs } + where + kc_sig (TypeSig _ op_ty) = discardResult (kcHsLiftedSigType op_ty) + kc_sig (GenericSig _ op_ty) = discardResult (kcHsLiftedSigType op_ty) + kc_sig _ = return () -kcTyClDecl (TySynonym {}) = panic "kcTyClDecl TySynonym" +kcTyClDecl (TySynonym {}) -- Type synonyms are never passed to kcTyClDecl + = panic "kcTyClDecl TySynonym" +-------------------- kcTyClDeclBody :: TyClDecl Name -> ([LHsTyVarBndr Name] -> TcM a) -> TcM a @@ -343,104 +407,84 @@ kcTyClDeclBody decl thing_inside zipWith add_kind hs_tvs kinds ; tcExtendKindEnvTvs kinded_tvs thing_inside } where - add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k) - add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k) + add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k) + add_kind (L loc (KindedTyVar n hsk _)) k = L loc (KindedTyVar n hsk k) +------------------- -- Kind check a data declaration, assuming that we already extended the -- kind environment with the type variables of the left-hand side (these -- kinded type variables are also passed as the second parameter). -- -kcDataDecl :: TyClDecl Name -> [LHsTyVarBndr Name] -> TcM (TyClDecl Name) -kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) - tvs - = do { ctxt' <- kcHsContext ctxt - ; cons' <- mapM (wrapLocM kc_con_decl) cons - ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) } - where +kcDataDecl :: TyClDecl Name -> TcM () +kcDataDecl (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) + = do { _ <- kcHsContext ctxt + ; _ <- mapM (wrapLocM (kcConDecl new_or_data)) cons + ; return () } +kcDataDecl d = pprPanic "kcDataDecl" (ppr d) + +------------------- +kcConDecl :: NewOrData -> ConDecl Name -> TcM (ConDecl Name) -- doc comments are typechecked to Nothing here - kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs - , con_cxt = ex_ctxt, con_details = details, con_res = res }) - = addErrCtxt (dataConCtxt name) $ - kcHsTyVars ex_tvs $ \ex_tvs' -> do - do { ex_ctxt' <- kcHsContext ex_ctxt - ; details' <- kc_con_details details - ; res' <- case res of - ResTyH98 -> return ResTyH98 - ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } - ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt' - , con_details = details', con_res = res' }) } - - kc_con_details (PrefixCon btys) - = do { btys' <- mapM kc_larg_ty btys +kcConDecl new_or_data con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs + , con_cxt = ex_ctxt, con_details = details, con_res = res }) + = addErrCtxt (dataConCtxt name) $ + kcHsTyVars ex_tvs $ \ex_tvs' -> + do { ex_ctxt' <- kcHsContext ex_ctxt + ; details' <- kc_con_details details + ; res' <- case res of + ResTyH98 -> return ResTyH98 + ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } + ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt' + , con_details = details', con_res = res' }) } + where + kc_con_details (PrefixCon btys) + = do { btys' <- mapM kc_larg_ty btys ; return (PrefixCon btys') } - kc_con_details (InfixCon bty1 bty2) - = do { bty1' <- kc_larg_ty bty1 + kc_con_details (InfixCon bty1 bty2) + = do { bty1' <- kc_larg_ty bty1 ; bty2' <- kc_larg_ty bty2 ; return (InfixCon bty1' bty2') } - kc_con_details (RecCon fields) - = do { fields' <- mapM kc_field fields + kc_con_details (RecCon fields) + = do { fields' <- mapM kc_field fields ; return (RecCon fields') } kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty - ; return (ConDeclField fld bty' d) } + ; return (ConDeclField fld bty' d) } kc_larg_ty bty = case new_or_data of - DataType -> kcHsSigType bty - NewType -> kcHsLiftedSigType bty - -- Can't allow an unlifted type for newtypes, because we're effectively - -- going to remove the constructor while coercing it to a lifted type. - -- And newtypes can't be bang'd -kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d) + DataType -> kcHsSigType bty + NewType -> kcHsLiftedSigType bty + -- Can't allow an unlifted type for newtypes, because we're effectively + -- going to remove the constructor while coercing it to a lifted type. + -- And newtypes can't be bang'd +------------------- -- Kind check a family declaration or type family default declaration. -- kcFamilyDecl :: [LHsTyVarBndr Name] -- tyvars of enclosing class decl if any - -> TyClDecl Name -> TcM (TyClDecl Name) + -> TyClDecl Name -> TcM () kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) = kcTyClDeclBody decl $ \tvs' -> do { mapM_ unifyClassParmKinds tvs' - ; return (decl {tcdTyVars = tvs', - tcdKind = kind `mplus` Just liftedTypeKind}) - -- default result kind is '*' - } + ; discardResult (scDsLHsMaybeKind kind) } where unifyClassParmKinds (L _ tv) | (n,k) <- hsTyVarNameKind tv , Just classParmKind <- lookup n classTyKinds - = unifyKind k classParmKind + = let ctxt = ptext ( sLit "When kind checking family declaration") + <+> ppr (tcdLName decl) + in addErrCtxt ctxt $ unifyKind k classParmKind >> return () | otherwise = return () classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs] -kcFamilyDecl _ decl@(TySynonym {}) - = return decl +kcFamilyDecl _ (TySynonym {}) = return () -- We don't have to do anything here for type family defaults: -- tcClassATs will use tcAssocDecl to check them kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d) -kcClassDecl :: TyClDecl Name -> TcM (TyClDecl Name) -kcClassDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats, tcdATDefs = atds}) - = kcTyClDeclBody decl $ \ tvs' -> - do { ctxt' <- kcHsContext ctxt - ; ats' <- mapM (wrapLocM (kcFamilyDecl tvs')) ats - ; atds' <- mapM (\def_ldecl@(L loc def_decl) -> setSrcSpan loc $ tcAddDefaultAssocDeclCtxt def_decl $ wrapLocM kcFamInstDecl def_ldecl) atds - ; sigs' <- mapM (wrapLocM kc_sig) sigs - ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs', - tcdATs = ats', tcdATDefs = atds'}) } - where - kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty - ; return (TypeSig nm op_ty') } - kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty - ; return (GenericSig nm op_ty') } - kc_sig other_sig = return other_sig - -kcClassDecl d = pprPanic "kcClassDecl" (ppr d) - -kcFamInstDecl :: TyClDecl Name -> TcM (TyClDecl Name) -kcFamInstDecl decl = kcFamTyPats decl $ \k_tvs k_typats resKind -> do - -- kind check the right-hand side of the type equation - k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) - -- ToDo: the ExpKind could be better - return (decl { tcdTyVars = k_tvs, tcdTyPats = Just k_typats, tcdSynRhs = k_rhs }) +------------------- +discardResult :: TcM a -> TcM () +discardResult a = a >> return () \end{code} @@ -450,9 +494,52 @@ kcFamInstDecl decl = kcFamTyPats decl $ \k_tvs k_typats resKind -> do %* * %************************************************************************ +Note [Type checking recursive type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At this point we have completed *kind-checking* of a mutually +recursive group of type/class decls (done in kcTyClGroup). However, +we discarded the kind-checked types (eg RHSs of data type decls); +note that kcTyClDecl returns (). There are two reasons: + + * It's convenient, because we don't have to rebuild a + kinded HsDecl (a fairly elaborate type) + + * It's necessary, because after kind-generalisation, the + TyCons/Classes may now be kind-polymorphic, and hence need + to be given kind arguments. + +Example: + data T f a = MkT (f a) (T f a) +During kind-checking, we give T the kind T :: k1 -> k2 -> * +and figure out constraints on k1, k2 etc. Then we generalise +to get T :: forall k. (k->*) -> k -> * +So now the (T f a) in the RHS must be elaborated to (T k f a). + +However, during tcTyClDecl of T (above) we will be in a recursive +"knot". So we aren't allowed to look at the TyCon T itself; we are only +allowed to put it (lazily) in the returned structures. But when +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) + +Then: + + * During TcHsType.kcTyVar we look in the *local* env, to get the + known kind for T. + + * But in TcHsType.ds_type (and ds_var_app in particular) we look in + the *global* env to get the TyCon. But we must be careful not to + force the TyCon or we'll get a loop. + +This fancy footwork (with two bindings for T) is only necesary for the +TyCons or Classes of this recursive group. Earlier, finished groups, +live in the global env only. + \begin{code} tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing] - tcTyClDecl calc_isrec (L loc decl) = setSrcSpan loc $ tcAddDeclCtxt decl $ traceTc "tcTyAndCl-x" (ppr decl) >> @@ -460,53 +547,48 @@ tcTyClDecl calc_isrec (L loc decl) -- "type family" declarations tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] -tcTyClDecl1 parent _calc_isrec - (TyFamily {tcdFlavour = TypeFamily, - tcdLName = L _ tc_name, tcdTyVars = tvs, - tcdKind = Just kind}) -- NB: kind at latest added during kind checking - = tcTyVarBndrs tvs $ \ tvs' -> do - { traceTc "type family:" (ppr tc_name) +tcTyClDecl1 parent _calc_isrec + (TyFamily {tcdFlavour = TypeFamily, tcdLName = L _ tc_name, tcdTyVars = tvs}) + = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do + { traceTc "type family:" (ppr tc_name) ; checkFamFlag tc_name ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing - ; return [ATyCon tycon] - } + ; return [ATyCon tycon] } -- "data family" declaration -tcTyClDecl1 parent _calc_isrec - (TyFamily {tcdFlavour = DataFamily, - tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind}) - = tcTyVarBndrs tvs $ \ tvs' -> do - { traceTc "data family:" (ppr tc_name) +tcTyClDecl1 parent _calc_isrec + (TyFamily {tcdFlavour = DataFamily, tcdLName = L _ tc_name, tcdTyVars = tvs}) + = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do + { traceTc "data family:" (ppr tc_name) ; checkFamFlag tc_name - ; extra_tvs <- tcDataKindSig mb_kind + ; extra_tvs <- tcDataKindSig kind ; let final_tvs = tvs' ++ extra_tvs -- we may not need these - ; tycon <- buildAlgTyCon tc_name final_tvs [] - DataFamilyTyCon Recursive True - parent Nothing - ; return [ATyCon tycon] - } + ; tycon <- buildAlgTyCon tc_name final_tvs [] + DataFamilyTyCon Recursive True parent Nothing + ; return [ATyCon tycon] } -- "type" synonym declaration tcTyClDecl1 _parent _calc_isrec - (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) + (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) = ASSERT( isNoParent _parent ) - tcTyVarBndrs tvs $ \ tvs' -> do - { traceTc "tcd1" (ppr tc_name) - ; rhs_ty' <- tcHsKindedType rhs_ty - ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') - (typeKind rhs_ty') NoParentTyCon Nothing + tcTyClTyVars tc_name tvs $ \ tvs' kind -> do + { rhs_ty' <- tcCheckHsType rhs_ty kind + ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') + kind NoParentTyCon Nothing ; return [ATyCon tycon] } -- "newtype" and "data" -- NB: not used for newtype/data instances (whether associated or not) tcTyClDecl1 _parent calc_isrec - (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, - tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) + (TyData { tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs + , tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons }) = ASSERT( isNoParent _parent ) - tcTyVarBndrs tvs $ \ tvs' -> do - { extra_tvs <- tcDataKindSig mb_ksig + let is_rec = calc_isrec tc_name + h98_syntax = consUseH98Syntax cons in + tcTyClTyVars tc_name tvs $ \ tvs' kind -> do + { extra_tvs <- tcDataKindSig kind ; let final_tvs = tvs' ++ extra_tvs - ; stupid_theta <- tcHsKindedContext ctxt + ; stupid_theta <- tcHsKindedContext =<< kcHsContext ctxt ; kind_signatures <- xoptM Opt_KindSignatures ; existential_ok <- xoptM Opt_ExistentialQuantification ; gadt_ok <- xoptM Opt_GADTs @@ -518,9 +600,9 @@ tcTyClDecl1 _parent calc_isrec ; dataDeclChecks tc_name new_or_data stupid_theta cons - ; tycon <- fixM (\ tycon -> do + ; tycon <- fixM (\ tycon -> do { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) - ; data_cons <- tcConDecls ex_ok tycon (final_tvs, res_ty) cons + ; data_cons <- tcConDecls new_or_data ex_ok tycon (final_tvs, res_ty) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means then return totallyAbstractTyConRhs -- "don't know"; hence totally Abstract @@ -531,34 +613,34 @@ tcTyClDecl1 _parent calc_isrec ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec (not h98_syntax) NoParentTyCon Nothing }) - ; return [ATyCon tycon] - } - where - is_rec = calc_isrec tc_name - h98_syntax = consUseH98Syntax cons + ; return [ATyCon tycon] } -tcTyClDecl1 _parent calc_isrec - (ClassDecl {tcdLName = L _ class_tycon_name, tcdTyVars = tvs, - tcdCtxt = ctxt, tcdMeths = meths, - tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats, tcdATDefs = at_defs} ) +tcTyClDecl1 _parent calc_isrec + (ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs + , tcdCtxt = ctxt, tcdMeths = meths + , tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats, tcdATDefs = at_defs }) = ASSERT( isNoParent _parent ) - tcTyVarBndrs tvs $ \ tvs' -> do - { ctxt' <- tcHsKindedContext ctxt - ; fds' <- mapM (addLocM tc_fundep) fundeps - ; (sig_stuff, gen_dm_env) <- tcClassSigs class_tycon_name sigs meths + do + { (tvs', ctxt', fds', sig_stuff, gen_dm_env) + <- tcTyClTyVars class_name tvs $ \ tvs' kind -> do + { MASSERT( isConstraintKind kind ) + ; ctxt' <- tcHsKindedContext =<< kcHsContext ctxt + ; fds' <- mapM (addLocM tc_fundep) fundeps + ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths + ; return (tvs', ctxt', fds', sig_stuff, gen_dm_env) } ; clas <- fixM $ \ clas -> do { let -- This little knot is just so we can get -- hold of the name of the class TyCon, which we -- need to look up its recursiveness tycon_name = tyConName (classTyCon clas) tc_isrec = calc_isrec tycon_name - - ; at_stuff <- tcClassATs clas tvs' ats at_defs + + ; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs -- NB: 'ats' only contains "type family" and "data family" declarations -- and 'at_defs' only contains associated-type defaults - + ; buildClass False {- Must include unfoldings for selectors -} - class_tycon_name tvs' ctxt' fds' at_stuff + class_name tvs' ctxt' fds' at_stuff sig_stuff tc_isrec } ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty) @@ -583,8 +665,6 @@ tcTyClDecl1 _parent calc_isrec tcTyClDecl1 _ _ (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] - -tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d) \end{code} %************************************************************************ @@ -594,24 +674,31 @@ tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d) %* * %************************************************************************ -Example: class C a where +Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The following is an example of associated type defaults: + class C a where data D a type F a b :: * type F a Z = [a] -- Default type F a (S n) = F a n -- Default -We can get default defns only for type families, not data families - +Note that: + - We can have more than one default definition for a single associated type, + as long as they do not overlap (same rules as for instances) + - We can get default definitions only for type families, not data families + \begin{code} -tcClassATs :: Class -- The class - -> [TyVar] -- Class type variables (can't look them up in class b/c its knot-tied) +tcClassATs :: Name -- The class name (not knot-tied) + -> TyConParent -- The class parent of this associated type -> [LTyClDecl Name] -- Associated types. All FamTyCon -> [LTyClDecl Name] -- Associated type defaults. All SynTyCon -> TcM [ClassATItem] -tcClassATs clas clas_tvs ats at_defs +tcClassATs class_name parent ats at_defs = do { -- Complain about associated type defaults for non associated-types - sequence_ [ failWithTc (badATErr clas n) + sequence_ [ failWithTc (badATErr class_name n) | n <- map (tcdName . unLoc) at_defs , not (n `elemNameSet` at_names) ] ; mapM tc_at ats } @@ -623,57 +710,41 @@ tcClassATs clas clas_tvs ats at_defs at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv (tcdName (unLoc at_def)) [at_def]) emptyNameEnv at_defs - tc_at at = do { [ATyCon fam_tc] <- addLocM (tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) at - ; atd <- mapM (tcDefaultAssocDecl fam_tc clas_tvs) - (lookupNameEnv at_defs_map (tyConName fam_tc) `orElse` []) + tc_at at = do { [ATyCon fam_tc] <- addLocM (tcTyClDecl1 parent + (const Recursive)) at + ; let at_defs = lookupNameEnv at_defs_map (tcdName (unLoc at)) + `orElse` [] + ; atd <- mapM (tcDefaultAssocDecl fam_tc) at_defs ; return (fam_tc, atd) } ------------------------- tcDefaultAssocDecl :: TyCon -- ^ Family TyCon - -> [TyVar] -- ^ TyVars of associated type's class -> LTyClDecl Name -- ^ RHS -> TcM ATDefault -- ^ Type checked RHS and free TyVars -tcDefaultAssocDecl fam_tc clas_tvs (L loc decl) +tcDefaultAssocDecl fam_tc (L loc decl) = setSrcSpan loc $ - tcAddDefaultAssocDeclCtxt decl $ + tcAddDefaultAssocDeclCtxt (tcdName decl) $ do { traceTc "tcDefaultAssocDecl" (ppr decl) ; (at_tvs, at_tys, at_rhs) <- tcSynFamInstDecl fam_tc decl - - -- See Note [Checking consistent instantiation] - -- We only want to check this on the *class* TyVars, - -- not the *family* TyVars (there may be more of these) - ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys - - ; return (ATD at_tvs at_tys at_rhs) } - where - check_arg fam_tc_tv at_ty - = checkTc (not (fam_tc_tv `elem` clas_tvs) || mkTyVarTy fam_tc_tv `eqType` at_ty) - (wrongATArgErr at_ty (mkTyVarTy fam_tc_tv)) - + ; return (ATD at_tvs at_tys at_rhs loc) } +-- We check for well-formedness and validity later, in checkValidClass ------------------------- + tcSynFamInstDecl :: TyCon -> TyClDecl Name -> TcM ([TyVar], [Type], Type) -tcSynFamInstDecl fam_tc (decl@TySynonym {}) - = do { -- check that the family declaration is for a synonym - checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) +tcSynFamInstDecl fam_tc (TySynonym { tcdTyVars = tvs, tcdTyPats = Just pats + , tcdSynRhs = rhs }) + = do { checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) - -- we need the exact same number of type parameters as the family - -- declaration - ; let famArity = tyConArity fam_tc - Just k_typats = tcdTyPats decl - ; checkTc (length k_typats == famArity) $ - wrongNumberOfParmsErr famArity + ; let kc_rhs rhs kind = kcCheckLHsType rhs (EK kind EkUnk) - -- type check type equation - ; tcTyVarBndrs (tcdTyVars decl) $ \t_tvs -> do -- turn kinded into proper tyvars - { t_typats <- mapM tcHsKindedType k_typats - ; t_rhs <- tcHsKindedType (tcdSynRhs decl) + ; tcFamTyPats fam_tc tvs pats (kc_rhs rhs) + $ \tvs' pats' res_kind -> do - -- NB: we don't check well-formedness of the instance here because we call - -- this function from within the TcTyClsDecls fixpoint. The callers must do - -- the check. + { rhs' <- kc_rhs rhs res_kind + ; rhs'' <- tcHsKindedType rhs' - ; return (t_tvs, t_typats, t_rhs) }} + ; return (tvs', pats', rhs'') } } tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl) @@ -684,33 +755,83 @@ tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl) -- not check whether there is a pattern for each type index; the latter -- check is only required for type synonym instances. -kcFamTyPats :: TyClDecl Name - -> ([LHsTyVarBndr Name] -> [LHsType Name] -> TcKind -> TcM a) - -- ^^kinded tvs ^^kinded ty pats ^^res kind +----------------- +tcFamTyPats :: TyCon + -> [LHsTyVarBndr Name] -> [LHsType Name] + -> (TcKind -> TcM any) -- Kind checker for RHS + -- result is ignored + -> ([KindVar] -> [TcKind] -> Kind -> TcM a) -> TcM a -kcFamTyPats decl thing_inside - = kcHsTyVars (tcdTyVars decl) $ \tvs -> - do { fam_tc_kind <- kcLookupKind (tcdLName decl) - - -- First, check that the shape of the kind implied by the - -- instance syntax matches that of the corresponding family - ; let hs_typats = fromJust $ tcdTyPats decl - ; pat_kinds <- mapM (\_ -> newKindVar) hs_typats - ; res_kind <- newKindVar - ; checkExpectedKind (tcdLName decl) fam_tc_kind (EK (mkArrowKinds pat_kinds res_kind) EkUnk) - -- TODO: better expected kind error? - - -- Next, ensure that the types in given patterns have the right kind - ; typats <- zipWithM kcCheckLHsType hs_typats - [ EK kind (EkArg (ppr (tcdLName decl)) n) - | (kind,n) <- pat_kinds `zip` [1..]] - - -- It is the responsibliity of the thing_inside to check that the instance - -- RHS has a kind matching that implied by the family - ; thing_inside tvs typats res_kind +-- Check the type patterns of a type or data family instance +-- type instance F <pat1> <pat2> = <type> +-- The 'tyvars' are the free type variables of pats +-- +-- NB: The family instance declaration may be an associated one, +-- nested inside an instance decl, thus +-- instance C [a] where +-- type F [a] = ... +-- In that case, the type variable 'a' will *already be in scope* +-- (and, if C is poly-kinded, so will its kind parameter). + +tcFamTyPats fam_tc tyvars pats kind_checker thing_inside + = kcHsTyVars tyvars $ \tvs -> + do { let (fam_kvs, body) = splitForAllTys (tyConKind fam_tc) + + -- A family instance must have exactly the same number of type + -- parameters as the family declaration. You can't write + -- type family F a :: * -> * + -- type instance F Int y = y + -- because then the type (F Int) would be like (\y.y) + ; let fam_arity = tyConArity fam_tc - length fam_kvs + ; checkTc (length pats == fam_arity) $ + wrongNumberOfParmsErr fam_arity + + -- Instantiate with meta kind vars + ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs + ; let body' = substKiWith fam_kvs fam_arg_kinds body + (kinds, resKind) = splitKindFunTysN fam_arity body' + ; typats <- zipWithM kcCheckLHsType pats + [ EK kind (EkArg (ppr fam_tc) n) + | (kind,n) <- kinds `zip` [1..]] + + -- Kind check the "thing inside"; this just works by + -- side-effecting any kind unification variables + ; _ <- kind_checker resKind + + -- Type check indexed data type declaration + -- We kind generalize the kind patterns since they contain + -- all the meta kind variables + -- See Note [Quantifying over family patterns] + ; tcTyVarBndrsKindGen tvs $ \tvs' -> do { + + ; (t_kvs, fam_arg_kinds') <- kindGeneralizeKinds fam_arg_kinds + ; k_typats <- mapM tcHsKindedType typats + + ; thing_inside (t_kvs ++ tvs') (fam_arg_kinds' ++ k_typats) resKind } } \end{code} +Note [Quantifying over family patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to quantify over two different lots of kind variables: + +First, the ones that come from tcTyVarBndrsKindGen, as usual + data family Dist a + + -- Proxy :: forall k. k -> * + data instance Dist (Proxy a) = DP + -- Generates data DistProxy = DP + -- ax8 k (a::k) :: Dist * (Proxy k a) ~ DistProxy k a + -- The 'k' comes from the tcTyVarBndrsKindGen (a::k) + +Second, the ones that come from the kind argument of the type family +which we pick up using kindGeneralizeKinds: + -- Any :: forall k. k + data instance Dist Any = DA + -- Generates data DistAny k = DA + -- ax7 k :: Dist k (Any k) ~ DistAny k + -- The 'k' comes from kindGeneralizeKinds (Any k) + Note [Associated type instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We allow this: @@ -779,29 +900,36 @@ dataDeclChecks tc_name new_or_data stupid_theta cons (emptyConDeclsErr tc_name) } ----------------------------------- -tcConDecls :: Bool -> TyCon -> ([TyVar], Type) +tcConDecls :: NewOrData -> Bool -> TyCon -> ([TyVar], Type) -> [LConDecl Name] -> TcM [DataCon] -tcConDecls ex_ok rep_tycon res_tmpl cons - = mapM (addLocM (tcConDecl ex_ok rep_tycon res_tmpl)) cons +tcConDecls new_or_data ex_ok rep_tycon res_tmpl cons + = mapM (addLocM (tcConDecl new_or_data ex_ok rep_tycon res_tmpl)) cons -tcConDecl :: Bool -- True <=> -XExistentialQuantificaton or -XGADTs +tcConDecl :: NewOrData + -> Bool -- True <=> -XExistentialQuantificaton or -XGADTs -> TyCon -- Representation tycon -> ([TyVar], Type) -- Return type template (with its template tyvars) -> ConDecl Name -> TcM DataCon -tcConDecl existential_ok rep_tycon res_tmpl -- Data types - con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt - , con_details = details, con_res = res_ty }) - = addErrCtxt (dataConCtxt name) $ - tcTyVarBndrs tvs $ \ tvs' -> do +tcConDecl new_or_data existential_ok rep_tycon res_tmpl -- Data types + con@(ConDecl {con_name = name}) + = do + { ConDecl { con_qvars = tvs, con_cxt = ctxt + , con_details = details, con_res = res_ty } + <- kcConDecl new_or_data con + ; addErrCtxt (dataConCtxt name) $ + tcTyVarBndrsKindGen tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; checkTc (existential_ok || conRepresentibleWithH98Syntax con) (badExistential name) + ; traceTc "tcConDecl 1" (ppr con) ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty - ; let + ; let tc_datacon is_infix field_lbls btys = do { (arg_tys, stricts) <- mapAndUnzipM tcConArg btys + ; traceTc "tcConDecl 3" (ppr name) + ; buildDataCon (unLoc name) is_infix stricts field_lbls univ_tvs ex_tvs eq_preds ctxt' arg_tys @@ -810,6 +938,7 @@ tcConDecl existential_ok rep_tycon res_tmpl -- Data types -- constructor type signature into the data constructor; -- that way checkValidDataCon can complain if it's wrong. + ; traceTc "tcConDecl 2" (ppr name) ; case details of PrefixCon btys -> tc_datacon False [] btys InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] @@ -817,7 +946,7 @@ tcConDecl existential_ok rep_tycon res_tmpl -- Data types where field_names = map (unLoc . cd_fld_name) fields btys = map cd_fld_type fields - } + } } -- Example -- data instance T (b,c) where @@ -838,7 +967,7 @@ tcResultType :: ([TyVar], Type) -- Template for result type; e.g. [(TyVar,Type)], -- Equality predicates Type) -- Typechecked return type -- We don't check that the TyCon given in the ResTy is - -- the same as the parent tycon, becuase we are in the middle + -- the same as the parent tycon, because we are in the middle -- of a recursive knot; so it's postponed until checkValidDataCon tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98 @@ -859,6 +988,11 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z) = do { res_ty' <- tcHsKindedType res_ty ; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty' + -- This 'Just' pattern is sure to match, because if not + -- checkValidDataCon will complain first. The 'subst' + -- should not be looked at until after checkValidDataCon + -- We can't check eagerly because we are in a "knot" in + -- which 'tycon' is not yet fully defined -- /Lazily/ figure out the univ_tvs etc -- Each univ_tv is either a dc_tv or a tmpl_tv @@ -868,7 +1002,9 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) = case tcGetTyVar_maybe ty of Just tv | not (tv `elem` univs) -> (tv:univs, eqs) - _other -> (tmpl:univs, (tmpl,ty):eqs) + _other -> (new_tmpl:univs, (new_tmpl,ty):eqs) + where -- see Note [Substitution in template variables kinds] + new_tmpl = updateTyVarKind (substTy subst) tmpl | otherwise = pprPanic "tcResultType" (ppr res_ty) ex_tvs = dc_tvs `minusList` univ_tvs @@ -886,6 +1022,44 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) name = tyVarName tv (env', occ') = tidyOccName env (getOccName name) +{- +Note [Substitution in template variables kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +data List a = Nil | Cons a (List a) +data SList s as where + SNil :: SList s Nil + +We call tcResultType with + tmpl_tvs = [(k :: BOX), (s :: k -> *), (as :: List k)] + res_tmpl = SList k s as + res_ty = ResTyGADT (SList k1 (s1 :: k1 -> *) (Nil k1)) + +We get subst: + k -> k1 + s -> s1 + as -> Nil k1 + +Now we want to find out the universal variables and the equivalences +between some of them and types (GADT). + +In this example, k and s are mapped to exactly variables which are not +already present in the universal set, so we just add them without any +coercion. + +But 'as' is mapped to 'Nil k1', so we add 'as' to the universal set, +and add the equivalence with 'Nil k1' in 'eqs'. + +The problem is that with kind polymorphism, as's kind may now contain +kind variables, and we have to apply the template substitution to it, +which is why we create new_tmpl. + +The template substitution only maps kind variables to kind variables, +since GADTs are not kind indexed. + +-} + + consUseH98Syntax :: [LConDecl a] -> Bool consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False consUseH98Syntax _ = True @@ -909,7 +1083,9 @@ conRepresentibleWithH98Syntax ------------------- tcConArg :: LHsType Name -> TcM (TcType, HsBang) tcConArg bty - = do { arg_ty <- tcHsBangType bty + = do { traceTc "tcConArg 1" (ppr bty) + ; arg_ty <- tcHsBangType bty + ; traceTc "tcConArg 2" (ppr bty) ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty) ; return (arg_ty, strict_mark) } @@ -1003,10 +1179,15 @@ checkValidTyCl :: TyClDecl Name -> TcM () -- only so that we can add a nice context with tcAddDeclCtxt checkValidTyCl decl = tcAddDeclCtxt decl $ - do { thing <- tcLookupLocatedGlobal (tcdLName decl) - ; traceTc "Validity of" (ppr thing) + do { traceTc "Validity of 1" (ppr decl) + ; env <- getGblEnv + ; traceTc "Validity of 1a" (ppr (tcg_type_env env)) + ; thing <- tcLookupLocatedGlobal (tcdLName decl) + ; traceTc "Validity of 2" (ppr decl) + ; traceTc "Validity of" (ppr thing) ; case thing of ATyCon tc -> do + traceTc " of kind" (ppr (tyConKind tc)) checkValidTyCon tc case decl of ClassDecl { tcdATs = ats } -> mapM_ (addLocM checkValidTyCl) ats @@ -1042,14 +1223,16 @@ checkValidTyCon tc SynFamilyTyCon {} -> return () SynonymTyCon ty -> checkValidType syn_ctxt ty | otherwise - = do -- Check the context on the data decl - checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) + = do { -- Check the context on the data decl + ; traceTc "cvtc1" (ppr tc) + ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) -- Check arg types of data constructors - mapM_ (checkValidDataCon tc) data_cons + ; traceTc "cvtc2" (ppr tc) + ; mapM_ (checkValidDataCon tc) data_cons -- Check that fields with the same name share a type - mapM_ check_fields groups + ; mapM_ check_fields groups } where syn_ctxt = TySynCtxt name @@ -1118,12 +1301,15 @@ checkValidDataCon tc con res_ty_tmpl actual_res_ty)) (badDataConTyCon con res_ty_tmpl actual_res_ty) + -- IA0_TODO: we should also check that kind variables + -- are only instantiated with kind variables ; checkValidMonoType (dataConOrigResTy con) -- Disallow MkT :: T (forall a. a->a) -- Reason: it's really the argument of an equality constraint ; checkValidType ctxt (dataConUserType con) ; when (isNewTyCon tc) (checkNewDataCon con) ; mapM_ check_bang (dataConStrictMarks con `zip` [1..]) + ; traceTc "Done validity of data con" (ppr con <+> ppr (dataConRepType con)) } where ctxt = ConArgCtxt (dataConName con) @@ -1171,8 +1357,9 @@ checkValidClass cls -- Check the class operations ; mapM_ (check_op constrained_class_methods) op_stuff - -- Check the associated type defaults are well-formed - ; mapM_ check_at at_stuff + -- Check the associated type defaults are well-formed and instantiated + -- See Note [Checking consistent instantiation] + ; mapM_ check_at_defs at_stuff -- Check that if the class has generic methods, then the -- class has only one parameter. We can't do generic @@ -1181,17 +1368,17 @@ checkValidClass cls } where (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls - unary = isSingleton tyvars + unary = isSingleton (snd (splitKiTyVars tyvars)) -- IA0_NOTE: only count type arguments no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff] check_op constrained_class_methods (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do - { checkValidTheta SigmaCtxt (tail theta) + { checkValidTheta ctxt (tail theta) -- The 'tail' removes the initial (C a) from the -- class itself, leaving just the method type ; traceTc "class op type" (ppr op_ty <+> ppr tau) - ; checkValidType (FunSigCtxt op_name) tau + ; checkValidType ctxt tau -- Check that the type mentions at least one of -- the class type variables...or at least one reachable @@ -1209,6 +1396,7 @@ checkValidClass cls _ -> return () } where + ctxt = FunSigCtxt op_name op_name = idName sel_id op_ty = idType sel_id (_,theta1,tau1) = tcSplitSigmaTy op_ty @@ -1222,8 +1410,21 @@ checkValidClass cls -- in the context of a for-all must mention at least one quantified -- type variable. What a mess! - check_at (_fam_tc, defs) - = mapM_ (\(ATD _tvs pats rhs) -> checkValidFamInst pats rhs) defs + check_at_defs (fam_tc, defs) + = do mapM_ (\(ATD _tvs pats rhs _loc) -> checkValidFamInst pats rhs) defs + tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $ + mapM_ (check_loc_at_def fam_tc) defs + + check_loc_at_def fam_tc (ATD _tvs pats _rhs loc) + -- Set the location for each of the default declarations + = setSrcSpan loc $ zipWithM_ check_arg (tyConTyVars fam_tc) pats + + -- We only want to check this on the *class* TyVars, + -- not the *family* TyVars (there may be more of these) + check_arg fam_tc_tv at_ty + = checkTc ( not (fam_tc_tv `elem` tyvars) + || mkTyVarTy fam_tc_tv `eqType` at_ty) + (wrongATArgErr at_ty (mkTyVarTy fam_tc_tv)) checkFamFlag :: Name -> TcM () -- Check that we don't use families without -XTypeFamilies @@ -1305,7 +1506,8 @@ mkRecSelBind (tycon, sel_name) is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs) (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] - | otherwise = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ + | otherwise = mkForAllTys (varSetElemsKvsFirst $ + data_tvs `extendVarSetList` field_tvs) $ mkPhiTy (dataConStupidTheta con1) $ -- Urgh! mkPhiTy field_theta $ -- Urgh! mkFunTy data_ty field_tau @@ -1447,12 +1649,12 @@ gotten by appying the eq_spec to the univ_tvs of the data con. %************************************************************************ \begin{code} -tcAddDefaultAssocDeclCtxt :: TyClDecl Name -> TcM a -> TcM a -tcAddDefaultAssocDeclCtxt decl thing_inside +tcAddDefaultAssocDeclCtxt :: Name -> TcM a -> TcM a +tcAddDefaultAssocDeclCtxt name thing_inside = addErrCtxt ctxt thing_inside where ctxt = hsep [ptext (sLit "In the type synonym instance default declaration for"), - quotes (ppr (tcdName decl))] + quotes (ppr name)] resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc resultTypeMisMatch field_name con1 con2 @@ -1522,7 +1724,7 @@ badDataConTyCon data_con res_ty_tmpl actual_res_ty ptext (sLit "returns type") <+> quotes (ppr actual_res_ty)) 2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl)) -badATErr :: Outputable a => a -> Name -> SDoc +badATErr :: Name -> Name -> SDoc badATErr clas op = hsep [ptext (sLit "Class"), quotes (ppr clas), ptext (sLit "does not have an associated type"), quotes (ppr op)] @@ -1584,7 +1786,12 @@ wrongATArgErr ty instTy = , ptext (sLit "Found") <+> quotes (ppr ty) <+> ptext (sLit "but expected") <+> quotes (ppr instTy) ] - +{- +tooManyParmsErr :: Name -> SDoc +tooManyParmsErr tc_name + = ptext (sLit "Family instance has too many parameters:") <+> + quotes (ppr tc_name) +-} wrongNumberOfParmsErr :: Arity -> SDoc wrongNumberOfParmsErr exp_arity = ptext (sLit "Number of parameters must match family declaration; expected") diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 52ee7a2b62..a81a909dd0 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -87,6 +87,7 @@ module TcType ( -- * Tidying type related things up for printing tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, + tidyOpenKind, tidyTyVarBndr, tidyFreeTyVars, tidyOpenTyVar, tidyOpenTyVars, tidyTopType, @@ -117,7 +118,7 @@ module TcType ( openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind, - kindVarRef, mkKindVar, + mkMetaKindVar, -------------------------------- -- Rexported from Type @@ -346,16 +347,15 @@ data UserTypeCtxt | ExprSigCtxt -- Expression type signature | ConArgCtxt Name -- Data constructor argument | TySynCtxt Name -- RHS of a type synonym decl - | GenPatCtxt -- Pattern in generic decl - -- f{| a+b |} (Inl x) = ... | LamPatSigCtxt -- Type sig in lambda pattern -- f (x::t) = ... | BindPatSigCtxt -- Type sig in pattern binding pattern -- (x::t, y) = e | ResSigCtxt -- Result type sig -- f x :: t = .... - | ForSigCtxt Name -- Foreign inport or export signature + | ForSigCtxt Name -- Foreign import or export signature | DefaultDeclCtxt -- Types in a default declaration + | InstDeclCtxt -- An instance declaration | SpecInstCtxt -- SPECIALISE instance pragma | ThBrackCtxt -- Template Haskell type brackets [t| ... |] | GenSigCtxt -- Higher-rank or impredicative situations @@ -363,6 +363,14 @@ data UserTypeCtxt -- We might want to elaborate this | GhciCtxt -- GHCi command :kind <type> + | ClassSCCtxt Name -- Superclasses of a class + | SigmaCtxt -- Theta part of a normal for-all type + -- f :: <S> => a -> a + | DataTyCtxt Name -- Theta part of a data decl + -- data <S> => T a = MkT a +\end{code} + + -- Notes re TySynCtxt -- We allow type synonyms that aren't types; e.g. type List = [] -- @@ -375,26 +383,19 @@ data UserTypeCtxt --------------------------------- -- Kind variables: - +\begin{code} mkKindName :: Unique -> Name mkKindName unique = mkSystemName unique kind_var_occ -kindVarRef :: KindVar -> IORef MetaDetails -kindVarRef tc = - ASSERT ( isTcTyVar tc ) - case tcTyVarDetails tc of - MetaTv TauTv ref -> ref - _ -> pprPanic "kindVarRef" (ppr tc) - -mkKindVar :: Unique -> IORef MetaDetails -> KindVar -mkKindVar u r +mkMetaKindVar :: Unique -> IORef MetaDetails -> MetaKindVar +mkMetaKindVar u r = mkTcTyVar (mkKindName u) tySuperKind -- not sure this is right, -- do we need kind vars for -- coercions? (MetaTv TauTv r) -kind_var_occ :: OccName -- Just one for all KindVars +kind_var_occ :: OccName -- Just one for all MetaKindVars -- They may be jiggled by tidying kind_var_occ = mkOccName tvName "k" \end{code} @@ -422,16 +423,19 @@ pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> qu pprUserTypeCtxt ExprSigCtxt = ptext (sLit "an expression type signature") pprUserTypeCtxt (ConArgCtxt c) = ptext (sLit "the type of the constructor") <+> quotes (ppr c) pprUserTypeCtxt (TySynCtxt c) = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c) -pprUserTypeCtxt GenPatCtxt = ptext (sLit "the type pattern of a generic definition") pprUserTypeCtxt ThBrackCtxt = ptext (sLit "a Template Haskell quotation [t|...|]") pprUserTypeCtxt LamPatSigCtxt = ptext (sLit "a pattern type signature") pprUserTypeCtxt BindPatSigCtxt = ptext (sLit "a pattern type signature") pprUserTypeCtxt ResSigCtxt = ptext (sLit "a result type signature") pprUserTypeCtxt (ForSigCtxt n) = ptext (sLit "the foreign declaration for") <+> quotes (ppr n) pprUserTypeCtxt DefaultDeclCtxt = ptext (sLit "a type in a `default' declaration") +pprUserTypeCtxt InstDeclCtxt = ptext (sLit "an instance declaration") pprUserTypeCtxt SpecInstCtxt = ptext (sLit "a SPECIALISE instance pragma") pprUserTypeCtxt GenSigCtxt = ptext (sLit "a type expected by the context") pprUserTypeCtxt GhciCtxt = ptext (sLit "a type in a GHCi command") +pprUserTypeCtxt (ClassSCCtxt c) = ptext (sLit "the super-classes of class") <+> quotes (ppr c) +pprUserTypeCtxt SigmaCtxt = ptext (sLit "the context of a polymorphic type") +pprUserTypeCtxt (DataTyCtxt tc) = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc) \end{code} @@ -447,13 +451,14 @@ pprUserTypeCtxt GhciCtxt = ptext (sLit "a type in a GHCi command") -- -- It doesn't change the uniques at all, just the print names. tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) -tidyTyVarBndr (tidy_env, subst) tyvar - = case tidyOccName tidy_env occ1 of +tidyTyVarBndr tidy_env@(occ_env, subst) tyvar + = case tidyOccName occ_env occ1 of (tidy', occ') -> ((tidy', subst'), tyvar') where subst' = extendVarEnv subst tyvar tyvar' - tyvar' = setTyVarName tyvar name' + tyvar' = setTyVarKind (setTyVarName tyvar name') kind' name' = tidyNameOcc name occ' + kind' = tidyKind tidy_env (tyVarKind tyvar) where name = tyVarName tyvar occ = getOccName name @@ -531,8 +536,11 @@ tidyTopType :: Type -> Type tidyTopType ty = tidyType emptyTidyEnv ty --------------- -tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind) -tidyKind env k = tidyOpenType env k +tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) +tidyOpenKind = tidyOpenType + +tidyKind :: TidyEnv -> Kind -> Kind +tidyKind = tidyType \end{code} %************************************************************************ @@ -973,13 +981,14 @@ tcInstHeadTyNotSynonym ty tcInstHeadTyAppAllTyVars :: Type -> Bool -- Used in Haskell-98 mode, for the argument types of an instance head --- These must be a constructor applied to type variable arguments +-- These must be a constructor applied to type variable arguments. +-- But we allow kind instantiations. tcInstHeadTyAppAllTyVars ty | Just ty' <- tcView ty -- Look through synonyms = tcInstHeadTyAppAllTyVars ty' | otherwise = case ty of - TyConApp _ tys -> ok tys + TyConApp _ tys -> ok (filter (not . isKind) tys) -- avoid kinds FunTy arg res -> ok [arg, res] _ -> False where @@ -1014,7 +1023,7 @@ shallowPredTypePredTree ev_ty () | Just clas <- tyConClass_maybe tc -> ClassPred clas tys () | tc `hasKey` eqTyConKey - , let [ty1, ty2] = tys + , let [_, ty1, ty2] = tys -> EqPred ty1 ty2 () | Just ip <- tyConIP_maybe tc , let [ty] = tys @@ -1153,9 +1162,7 @@ deNoteType :: Type -> Type -- Remove all *outermost* type synonyms and other notes deNoteType ty | Just ty' <- tcView ty = deNoteType ty' deNoteType ty = ty -\end{code} -\begin{code} tcTyVarsOfType :: Type -> TcTyVarSet -- Just the *TcTyVars* free in the type -- (Types.tyVarsOfTypes finds all free TyVars) diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index b73f70447d..67bafaca36 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -14,12 +14,12 @@ Type subsumption and unification -- for details module TcUnify ( - -- Full-blown subsumption + -- Full-blown subsumption tcWrapResult, tcSubType, tcGen, checkConstraints, newImplication, sigCtxt, - -- Various unifications - unifyType, unifyTypeList, unifyTheta, unifyKind, + -- Various unifications + unifyType, unifyTypeList, unifyTheta, unifyKind, unifyKindEq, -------------------------------- -- Holes @@ -31,7 +31,12 @@ module TcUnify ( matchExpectedFunTys, matchExpectedFunKind, wrapFunResCoercion, - failWithMisMatch + failWithMisMatch, + + -------------------------------- + -- Errors + mkKindErrorCtxt + ) where #include "HsVersions.h" @@ -46,17 +51,17 @@ import TcRnMonad import TcType import Type import Coercion +import Name ( isSystemName ) import Inst -import Kind ( isConstraintKind, isConstraintKindCon ) +import Kind import TyCon import TysWiredIn import Var import VarSet import VarEnv -import Name import ErrUtils import BasicTypes -import Maybes ( allMaybes ) +import Maybes ( allMaybes ) import Util import Outputable import FastString @@ -198,10 +203,10 @@ matchExpectedPArrTy exp_ty ; return (co, elt_ty) } ---------------------- -matchExpectedTyConApp :: TyCon -- T :: k1 -> ... -> kn -> * +matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> * -> TcRhoType -- orig_ty - -> TcM (LCoercion, -- T a b c ~ orig_ty - [TcSigmaType]) -- Element types, a b c + -> TcM (LCoercion, -- T k1 k2 k3 a b c ~ orig_ty + [TcSigmaType]) -- Element types, k1 k2 k3 a b c -- It's used for wired-in tycons, so we call checkWiredInTyCon -- Precondition: never called with FunTyCon @@ -239,11 +244,14 @@ matchExpectedTyConApp tc orig_ty ---------- defer n_req ty tys - = do { tau_tys <- mapM newFlexiTyVarTy arg_kinds - ; co <- unifyType (mkTyConApp tc tau_tys) ty - ; return (co, tau_tys ++ tys) } + = do { kappa_tys <- mapM (const newMetaKindVar) kvs + ; let arg_kinds' = map (substKiWith kvs kappa_tys) arg_kinds + ; tau_tys <- mapM newFlexiTyVarTy arg_kinds' + ; co <- unifyType (mkTyConApp tc (kappa_tys ++ tau_tys)) ty + ; return (co, kappa_tys ++ tau_tys ++ tys) } where - (arg_kinds, _) = splitKindFunTysN n_req (tyConKind tc) + (kvs, body) = splitForAllTys (tyConKind tc) + (arg_kinds, _) = splitKindFunTysN (n_req - length kvs) body ---------------------- matchExpectedAppTy :: TcRhoType -- orig_ty @@ -574,10 +582,7 @@ uType_np origin orig_ty1 orig_ty2 go (TyVarTy tyvar1) ty2 = uVar origin NotSwapped tyvar1 ty2 go ty1 (TyVarTy tyvar2) = uVar origin IsSwapped tyvar2 ty1 - -- Expand synonyms: - -- see Note [Unification and synonyms] - -- Do this after the variable case so that we tend to unify - -- variables with un-expanded type synonym + -- See Note [Expanding synonyms during unification] -- -- Also NB that we recurse to 'go' so that we don't push a -- new item on the origin stack. As a result if we have @@ -715,48 +720,19 @@ So either Currently we adopt (b) since it seems more robust -- no need to maintain a global invariant. -Note [Unification and synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you are tempted to make a short cut on synonyms, as in this -pseudocode... - - uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2) - = if (con1 == con2) then - -- Good news! Same synonym constructors, so we can shortcut - -- by unifying their arguments and ignoring their expansions. - unifyTypepeLists args1 args2 - else - -- Never mind. Just expand them and try again - uTys ty1 ty2 - -then THINK AGAIN. Here is the whole story, as detected and reported -by Chris Okasaki: - -Here's a test program that should detect the problem: - - type Bogus a = Int - x = (1 :: Bogus Char) :: Bogus Bool - -The problem with [the attempted shortcut code] is that - - con1 == con2 - -is not a sufficient condition to be able to use the shortcut! -You also need to know that the type synonym actually USES all -its arguments. For example, consider the following type synonym -which does not use all its arguments. - - type Bogus a = Int - -If you ever tried unifying, say, (Bogus Char) with )Bogus Bool), the -unifier would blithely try to unify Char with Bool and would fail, -even though the expanded forms (both Int) should match. Similarly, -unifying (Bogus Char) with (Bogus t) would unnecessarily bind t to -Char. +Note [Expanding synonyms during unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We expand synonyms during unification, but: + * We expand *after* the variable case so that we tend to unify + variables with un-expanded type synonym. This just makes it + more likely that the inferred types will mention type synonyms + understandable to the user -... You could explicitly test for the problem synonyms and mark them -somehow as needing expansion, perhaps also issuing a warning to the -user. + * We expand *before* the TyConApp case. For example, if we have + type Phantom a = Int + and are unifying + Phantom Int ~ Phantom Char + it is *wrong* to unify Int and Char. Note [Deferred Unification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -857,29 +833,31 @@ uUnfilledVars :: [EqOrigin] -- Neither is filled in yet uUnfilledVars origin swapped tv1 details1 tv2 details2 - = case (details1, details2) of - (MetaTv i1 ref1, MetaTv i2 ref2) - | k1_sub_k2 -> if k2_sub_k1 && nicer_to_update_tv1 i1 i2 - then updateMeta tv1 ref1 ty2 - else updateMeta tv2 ref2 ty1 - | k2_sub_k1 -> updateMeta tv1 ref1 ty2 - - (_, MetaTv _ ref2) | k1_sub_k2 -> updateMeta tv2 ref2 ty1 - (MetaTv _ ref1, _) | k2_sub_k1 -> updateMeta tv1 ref1 ty2 - - (_, _) -> unSwap swapped (uType_defer origin) ty1 ty2 - -- Defer for skolems of all sorts + = do { traceTc "uUnfilledVars" ( text "trying to unify" <+> ppr k1 + <+> text "with" <+> ppr k2) + ; let ctxt = mkKindErrorCtxt ty1 ty2 k1 k2 + ; sub_kind <- addErrCtxtM ctxt $ unifyKind k1 k2 + + ; case (sub_kind, details1, details2) of + -- k1 <= k2, so update tv2 + (LT, _, MetaTv _ ref2) -> updateMeta tv2 ref2 ty1 + -- k2 <= k1, so update tv1 + (GT, MetaTv _ ref1, _) -> updateMeta tv1 ref1 ty2 + (EQ, MetaTv i1 ref1, MetaTv i2 ref2) + | nicer_to_update_tv1 i1 i2 -> updateMeta tv1 ref1 ty2 + | otherwise -> updateMeta tv2 ref2 ty1 + + (_, _, _) -> unSwap swapped (uType_defer origin) ty1 ty2 } + -- Defer for skolems of all sorts where - k1 = tyVarKind tv1 - k2 = tyVarKind tv2 - k1_sub_k2 = k1 `isSubKind` k2 - k2_sub_k1 = k2 `isSubKind` k1 - ty1 = mkTyVarTy tv1 - ty2 = mkTyVarTy tv2 + k1 = tyVarKind tv1 + k2 = tyVarKind tv2 + ty1 = mkTyVarTy tv1 + ty2 = mkTyVarTy tv2 nicer_to_update_tv1 _ SigTv = True nicer_to_update_tv1 SigTv _ = False - nicer_to_update_tv1 _ _ = isSystemName (Var.varName tv1) + nicer_to_update_tv1 _ _ = isSystemName (Var.varName tv1) -- Try not to update SigTvs; and try to update sys-y type -- variables in preference to ones gotten (say) by -- instantiating a polymorphic function with a user-written @@ -890,7 +868,7 @@ checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType) -- (checkTauTvUpdate tv ty) -- We are about to update the TauTv tv with ty. -- Check (a) that tv doesn't occur in ty (occurs check) --- (b) that kind(ty) is a sub-kind of kind(tv) +-- (b) that kind(ty) is a sub-kind of kind(tv) -- (c) that ty does not contain any type families, see Note [Type family sharing] -- -- We have two possible outcomes: @@ -910,26 +888,36 @@ checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType) checkTauTvUpdate tv ty = do { ty' <- zonkTcType ty - ; if typeKind ty' `isSubKind` tyVarKind tv then - case ok ty' of - Nothing -> return Nothing - Just ty'' -> return (Just ty'') - else return Nothing } - - where ok :: TcType -> Maybe TcType - ok (TyVarTy tv') | not (tv == tv') = Just (TyVarTy tv') - ok this_ty@(TyConApp tc tys) - | not (isSynFamilyTyCon tc), Just tys' <- allMaybes (map ok tys) - = Just (TyConApp tc tys') - | isSynTyCon tc, Just ty_expanded <- tcView this_ty - = ok ty_expanded -- See Note [Type synonyms and the occur check] - ok (FunTy arg res) | Just arg' <- ok arg, Just res' <- ok res - = Just (FunTy arg' res') - ok (AppTy fun arg) | Just fun' <- ok fun, Just arg' <- ok arg - = Just (AppTy fun' arg') - ok (ForAllTy tv1 ty1) | Just ty1' <- ok ty1 = Just (ForAllTy tv1 ty1') - -- Fall-through - ok _ty = Nothing + ; let k2 = typeKind ty' + ; k1 <- zonkTcKind (tyVarKind tv) + ; let ctxt = mkKindErrorCtxt (mkTyVarTy tv) ty' k1 k2 + ; sub_k <- addErrCtxtM ctxt $ + unifyKind (tyVarKind tv) (typeKind ty') + + ; case sub_k of + LT -> return Nothing + _ -> return (ok ty') } + where + ok :: TcType -> Maybe TcType + -- Checks that tv does not occur in the arg type + -- expanding type synonyms where necessary to make this so + -- eg type Phantom a = Bool + -- ok (tv -> Int) = Nothing + -- ok (x -> Int) = Just (x -> Int) + -- ok (Phantom tv -> Int) = Just (Bool -> Int) + ok (TyVarTy tv') | not (tv == tv') = Just (TyVarTy tv') + ok this_ty@(TyConApp tc tys) + | not (isSynFamilyTyCon tc), Just tys' <- allMaybes (map ok tys) + = Just (TyConApp tc tys') + | isSynTyCon tc, Just ty_expanded <- tcView this_ty + = ok ty_expanded -- See Note [Type synonyms and the occur check] + ok (FunTy arg res) | Just arg' <- ok arg, Just res' <- ok res + = Just (FunTy arg' res') + ok (AppTy fun arg) | Just fun' <- ok fun, Just arg' <- ok arg + = Just (AppTy fun' arg') + ok (ForAllTy tv1 ty1) | Just ty1' <- ok ty1 = Just (ForAllTy tv1 ty1') + -- Fall-through + ok _ty = Nothing \end{code} Note [Avoid deferring] @@ -1130,115 +1118,144 @@ matchExpectedFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind)) -- Like unifyFunTy, but does not fail; instead just returns Nothing matchExpectedFunKind (TyVarTy kvar) = do - maybe_kind <- readKindVar kvar + maybe_kind <- readMetaTyVar kvar case maybe_kind of Indirect fun_kind -> matchExpectedFunKind fun_kind Flexi -> - do { arg_kind <- newKindVar - ; res_kind <- newKindVar - ; writeKindVar kvar (mkArrowKind arg_kind res_kind) + do { arg_kind <- newMetaKindVar + ; res_kind <- newMetaKindVar + ; writeMetaTyVar kvar (mkArrowKind arg_kind res_kind) ; return (Just (arg_kind,res_kind)) } matchExpectedFunKind (FunTy arg_kind res_kind) = return (Just (arg_kind,res_kind)) matchExpectedFunKind _ = return Nothing ------------------ -unifyKind :: TcKind -- Expected - -> TcKind -- Actual - -> TcM () - -unifyKind (TyConApp kc1 []) (TyConApp kc2 []) - | isSubKindCon kc2 kc1 - , not (isConstraintKindCon kc2) || isConstraintKindCon kc1 = return () - -- For the purposes of the front end ONLY, only allow - -- the Constraint kind to unify with itself. - -- - -- This prevents the user from writing constraints types - -- on the left or right of an arrow. - -unifyKind (FunTy a1 r1) (FunTy a2 r2) - = do { unifyKind a2 a1; unifyKind r1 r2 } - -- Notice the flip in the argument, - -- so that the sub-kinding works right +----------------- +unifyKind :: TcKind -- k1 (actual) + -> TcKind -- k2 (expected) + -> TcM Ordering -- Returns the relation between the kinds + -- LT <=> k1 is a sub-kind of k2 + unifyKind (TyVarTy kv1) k2 = uKVar False kv1 k2 -unifyKind k1 (TyVarTy kv2) = uKVar True kv2 k1 -unifyKind k1 k2 = unifyKindMisMatch k1 k2 +unifyKind k1 (TyVarTy kv2) = uKVar True kv2 k1 + +unifyKind k1 k2 -- See Note [Expanding synonyms during unification] + | Just k1' <- tcView k1 = unifyKind k1' k2 + | Just k2' <- tcView k2 = unifyKind k1 k2' + +unifyKind k1@(TyConApp kc1 []) k2@(TyConApp kc2 []) + | kc1 == kc2 = return EQ + | kc1 `tcIsSubKindCon` kc2 = return LT + | kc2 `tcIsSubKindCon` kc1 = return GT + | otherwise = unifyKindMisMatch k1 k2 + +unifyKind k1 k2 = do { unifyKindEq k1 k2; return EQ } + -- In all other cases, let unifyKindEq do the work + +uKVar :: Bool -> MetaKindVar -> TcKind -> TcM Ordering +uKVar isFlipped kv1 k2 + | isMetaTyVar kv1 + = do { mb_k1 <- readMetaTyVar kv1 + ; case mb_k1 of + Flexi -> uUnboundKVar kv1 k2 >> return EQ + Indirect k1 -> unifyKind k1 k2 } + | TyVarTy kv2 <- k2, isMetaTyVar kv2 + = uKVar (not isFlipped) kv2 (TyVarTy kv1) + | TyVarTy kv2 <- k2, kv1 == kv2 = return EQ + | otherwise = if isFlipped + then unifyKindMisMatch k2 (TyVarTy kv1) + else unifyKindMisMatch (TyVarTy kv1) k2 + +--------------------------- +unifyKindEq :: TcKind -> TcKind -> TcM () +unifyKindEq (TyVarTy kv1) k2 = uKVarEq False kv1 k2 +unifyKindEq k1 (TyVarTy kv2) = uKVarEq True kv2 k1 + +unifyKindEq (FunTy a1 r1) (FunTy a2 r2) + = do { unifyKindEq a1 a2; unifyKindEq r1 r2 } + +unifyKindEq (TyConApp kc1 k1s) (TyConApp kc2 k2s) + | kc1 == kc2 + = ASSERT (length k1s == length k2s) + -- Should succeed since the kind constructors are the same, + -- and the kinds are sort-checked, thus fully applied + zipWithM_ unifyKindEq k1s k2s + +unifyKindEq k1 k2 = unifyKindMisMatch k1 k2 ---------------- -uKVar :: Bool -> KindVar -> TcKind -> TcM () -uKVar swapped kv1 k2 - = do { mb_k1 <- readKindVar kv1 +-- For better error messages, we record whether we've flipped the kinds +-- during the process. +uKVarEq :: Bool -> MetaKindVar -> TcKind -> TcM () +uKVarEq isFlipped kv1 k2 + | isMetaTyVar kv1 + = do { mb_k1 <- readMetaTyVar kv1 ; case mb_k1 of - Flexi -> uUnboundKVar swapped kv1 k2 - Indirect k1 | swapped -> unifyKind k2 k1 - | otherwise -> unifyKind k1 k2 } + Flexi -> uUnboundKVar kv1 k2 + Indirect k1 -> unifyKindEq k1 k2 } + | TyVarTy kv2 <- k2, isMetaTyVar kv2 + = uKVarEq (not isFlipped) kv2 (TyVarTy kv1) + | TyVarTy kv2 <- k2, kv1 == kv2 = return () + | otherwise = if isFlipped + then unifyKindMisMatch k2 (TyVarTy kv1) + else unifyKindMisMatch (TyVarTy kv1) k2 ---------------- -uUnboundKVar :: Bool -> KindVar -> TcKind -> TcM () -uUnboundKVar swapped kv1 k2@(TyVarTy kv2) +uUnboundKVar :: MetaKindVar -> TcKind -> TcM () +uUnboundKVar kv1 k2@(TyVarTy kv2) | kv1 == kv2 = return () - | otherwise -- Distinct kind variables - = do { mb_k2 <- readKindVar kv2 + | isMetaTyVar kv2 -- Distinct kind variables + = do { mb_k2 <- readMetaTyVar kv2 ; case mb_k2 of - Indirect k2 -> uUnboundKVar swapped kv1 k2 - Flexi -> writeKindVar kv1 k2 } + Indirect k2 -> uUnboundKVar kv1 k2 + Flexi -> writeMetaTyVar kv1 k2 } + | otherwise = writeMetaTyVar kv1 k2 -uUnboundKVar swapped kv1 non_var_k2 +uUnboundKVar kv1 non_var_k2 = do { k2' <- zonkTcKind non_var_k2 ; kindOccurCheck kv1 k2' - ; k2'' <- kindSimpleKind swapped k2' - -- KindVars must be bound only to simple kinds - -- Polarities: (kindSimpleKind True ?) succeeds - -- returning *, corresponding to unifying - -- expected: ? - -- actual: kind-ver - ; writeKindVar kv1 k2'' } + ; let k2'' = kindSimpleKind k2' + -- MetaKindVars must be bound only to simple kinds + ; writeMetaTyVar kv1 k2'' } ---------------- kindOccurCheck :: TyVar -> Type -> TcM () kindOccurCheck kv1 k2 -- k2 is zonked - = checkTc (not_in k2) (kindOccurCheckErr kv1 k2) - where - not_in (TyVarTy kv2) = kv1 /= kv2 - not_in (FunTy a2 r2) = not_in a2 && not_in r2 - not_in _ = True - -kindSimpleKind :: Bool -> Kind -> TcM SimpleKind --- (kindSimpleKind True k) returns a simple kind sk such that sk <: k --- If the flag is False, it requires k <: sk --- E.g. kindSimpleKind False ?? = * --- What about (kv -> *) ~ ?? -> * -kindSimpleKind orig_swapped orig_kind - = go orig_swapped orig_kind - where - go sw (FunTy k1 k2) = do { k1' <- go (not sw) k1 - ; k2' <- go sw k2 - ; return (mkArrowKind k1' k2') } - go True k - | isOpenTypeKind k = return liftedTypeKind - | isArgTypeKind k = return liftedTypeKind - go _ k - | isLiftedTypeKind k = return liftedTypeKind - | isUnliftedTypeKind k = return unliftedTypeKind - | isConstraintKind k = return constraintKind - go _ k@(TyVarTy _) = return k -- KindVars are always simple - go _ _ = failWithTc (ptext (sLit "Unexpected kind unification failure:") - <+> ppr orig_swapped <+> ppr orig_kind) - -- I think this can't actually happen - --- T v = MkT v v must be a type --- T v w = MkT (v -> w) v must not be an umboxed tuple - -unifyKindMisMatch :: TcKind -- Expected - -> TcKind -- Actual - -> TcM () -unifyKindMisMatch ty1 ty2 = do - ty1' <- zonkTcKind ty1 - ty2' <- zonkTcKind ty2 - failWithTc $ hang (ptext (sLit "Couldn't match kind")) - 2 (sep [quotes (ppr ty1'), - ptext (sLit "against"), - quotes (ppr ty2')]) + = if elemVarSet kv1 (tyVarsOfType k2) + then failWithTc (kindOccurCheckErr kv1 k2) + else return () + +kindSimpleKind :: Kind -> SimpleKind +-- (kindSimpleKind k) returns a simple kind k' such that k' <= k +kindSimpleKind k + | isOpenTypeKind k = liftedTypeKind + | isArgTypeKind k = liftedTypeKind + | otherwise = k + +mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) +mkKindErrorCtxt ty1 ty2 k1 k2 env0 + = let (env1, ty1') = tidyOpenType env0 ty1 + (env2, ty2') = tidyOpenType env1 ty2 + (env3, k1' ) = tidyOpenKind env2 k1 + (env4, k2' ) = tidyOpenKind env3 k2 + in do ty1 <- zonkTcType ty1' + ty2 <- zonkTcType ty2' + k1 <- zonkTcKind k1' + k2 <- zonkTcKind k2' + return (env4, + vcat [ ptext (sLit "Kind incompatibility when matching types:") + , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1 + , ppr ty2 <+> dcolon <+> ppr k2 ]) ]) + +unifyKindMisMatch :: TcKind -> TcKind -> TcM a +unifyKindMisMatch ki1 ki2 = do + ki1' <- zonkTcKind ki1 + ki2' <- zonkTcKind ki2 + let msg = hang (ptext (sLit "Couldn't match kind")) + 2 (sep [quotes (ppr ki1'), + ptext (sLit "against"), + quotes (ppr ki2')]) + failWithTc msg ---------------- kindOccurCheckErr :: Var -> Type -> SDoc diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.lhs-boot index 431bfaabdc..ac4d5ddc78 100644 --- a/compiler/typecheck/TcUnify.lhs-boot +++ b/compiler/typecheck/TcUnify.lhs-boot @@ -7,12 +7,16 @@ -- for details module TcUnify where -import TcType ( TcTauType ) -import TcRnTypes( TcM ) -import Coercion (LCoercion) +import TcType ( TcTauType, TcKind, Type, Kind ) +import VarEnv ( TidyEnv ) +import TcRnTypes ( TcM ) +import Coercion ( LCoercion ) +import Outputable ( SDoc ) -- This boot file exists only to tie the knot between --- TcUnify and Inst +-- TcUnify and Inst unifyType :: TcTauType -> TcTauType -> TcM LCoercion +unifyKindEq :: TcKind -> TcKind -> TcM () +mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) \end{code} diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index 1878237499..cda98de45e 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -39,6 +39,7 @@ import BasicTypes import Unique import Util import Outputable +import SrcLoc import FastString import Data.Typeable (Typeable) @@ -56,14 +57,16 @@ A @Class@ corresponds to a Greek kappa in the static semantics: \begin{code} data Class = Class { - classTyCon :: TyCon, -- The data type constructor for - -- dictionaries of this class + classTyCon :: TyCon, -- The data type constructor for + -- dictionaries of this class + -- See Note [ATyCon for classes] in TypeRep className :: Name, -- Just the cached name of the TyCon classKey :: Unique, -- Cached unique of TyCon - classTyVars :: [TyVar], -- The class type variables; + classTyVars :: [TyVar], -- The class kind and type variables; -- identical to those of the TyCon + classFunDeps :: [FunDep TyVar], -- The functional dependencies -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b) @@ -97,12 +100,19 @@ type ClassATItem = (TyCon, [ATDefault]) -- Default associated types from these templates. If the template list is empty, -- we assume that there is no default -- not that the default is to generate no -- instances (this only makes a difference for warnings). - -data ATDefault = ATD [TyVar] [Type] Type - -- Each associated type default template is a triple of: - -- 1. TyVars of the RHS and family arguments (including the class TVs) - -- 3. The instantiated family arguments - -- 2. The RHS of the synonym + -- We can have more than one default per type; see + -- Note [Associated type defaults] in TcTyClsDecls + +-- Each associated type default template is a triple of: +data ATDefault = ATD { -- TyVars of the RHS and family arguments + -- (including the class TVs) + atDefaultTys :: [TyVar], + -- The instantiated family arguments + atDefaultPats :: [Type], + -- The RHS of the synonym + atDefaultRhs :: Type, + -- The source location of the synonym + atDefaultSrcSpan :: SrcSpan } -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in -- the `DefMeth` constructor of the `DefMeth`. diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index f21f0cae95..44854fdf94 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -19,19 +19,7 @@ module Coercion ( Coercion(..), Var, CoVar, LCoercion, - -- ** Deconstructing Kinds - kindFunResult, kindAppResult, synTyConResKind, - splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe, - - -- ** Predicates on Kinds - isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, - isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, - isSuperKind, - mkArrowKind, mkArrowKinds, - - isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind, - isSubKindCon, - + -- ** Functions over coercions coVarKind, coVarKind_maybe, coercionType, coercionKind, coercionKinds, isReflCo, mkCoercionType, @@ -90,7 +78,6 @@ import Unify ( MatchEnv(..), matchList ) import TypeRep import qualified Type import Type hiding( substTy, substTyVarBndr, extendTvSubst ) -import Kind import TyCon import Var import VarEnv @@ -161,21 +148,22 @@ data Coercion deriving (Data.Data, Data.Typeable) \end{code} +Note [LCoercions] +~~~~~~~~~~~~~~~~~ +| LCoercions are a hack used by the typechecker. Normally, +Coercions have free variables of type (a ~# b): we call these +CoVars. However, the type checker passes around equality evidence +(boxed up) at type (a ~ b). + +An LCoercion is simply a Coercion whose free variables have the +boxed type (a ~ b). After we are done with typechecking the +desugarer finds the free variables, unboxes them, and creates a +resulting real Coercion with kosher free variables. + +We can use most of the Coercion "smart constructors" to build LCoercions. However, +mkCoVarCo will not work! The equivalent is mkEqVarLCo. + \begin{code} --- Note [LCoercions] --- ~~~~~~~~~~~~~~~~~ --- | LCoercions are a hack used by the typechecker. Normally, --- Coercions have free variables of type (a ~# b): we call these --- CoVars. However, the type checker passes around equality evidence --- (boxed up) at type (a ~ b). --- --- An LCoercion is simply a Coercion whose free variables have the --- boxed type (a ~ b). After we are done with typechecking the --- desugarer finds the free variables, unboxes them, and creates a --- resulting real Coercion with kosher free variables. --- --- We can use most of the Coercion "smart constructors" to build LCoercions. However, --- mkCoVarCo will not work! The equivalent is mkEqVarLCo. type LCoercion = Coercion \end{code} @@ -281,6 +269,30 @@ predicates too: Nth 1 ((~) [c] g) = g See Simplify.simplCoercionF, which generates such selections. +Note [Kind coercions] +~~~~~~~~~~~~~~~~~~~~~ +Suppose T :: * -> *, and g :: A ~ B +Then the coercion + TyConAppCo T [g] T g : T A ~ T B + +Now suppose S :: forall k. k -> *, and g :: A ~ B +Then the coercion + TyConAppCo S [Refl *, g] T <*> g : T * A ~ T * B + +Notice that the arguments to TyConAppCo are coercions, but the first +represents a *kind* coercion. Now, we don't allow any non-trivial kind +coercions, so it's an invariant that any such kind coercions are Refl. +Lint checks this. + +However it's inconvenient to insist that these kind coercions are always +*structurally* (Refl k), because the key function exprIsConApp_maybe +pushes coercions into constructor arguments, so + C k ty e |> g +may turn into + C (Nth 0 g) .... +Now (Nth 0 g) will optimise to Refl, but perhaps not instantly. + + %************************************************************************ %* * \subsection{Coercion variables} @@ -446,6 +458,7 @@ pprCoAxiom ax -- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c] decomposeCo :: Arity -> Coercion -> [Coercion] decomposeCo arity co = [mkNthCo n co | n <- [0..(arity-1)] ] + -- Remember, Nth is zero-indexed -- | Attempts to obtain the type variable underlying a 'Coercion' getCoVar_maybe :: Coercion -> Maybe CoVar @@ -488,7 +501,7 @@ coVarKind cv = case coVarKind_maybe cv of coVarKind_maybe :: CoVar -> Maybe (Type,Type) coVarKind_maybe cv = case splitTyConApp_maybe (varType cv) of - Just (tc, [ty1, ty2]) | tc `hasKey` eqPrimTyConKey -> Just (ty1, ty2) + Just (tc, [_, ty1, ty2]) | tc `hasKey` eqPrimTyConKey -> Just (ty1, ty2) _ -> Nothing -- | Makes a coercion type from two types: the types whose equality @@ -923,6 +936,9 @@ ty_co_subst subst ty -- won't be in the substitution go (AppTy ty1 ty2) = mkAppCo (go ty1) (go ty2) go (TyConApp tc tys) = mkTyConAppCo tc (map go tys) + -- IA0_NOTE: Do we need to do anything + -- about kind instantiations? I don't think + -- so. see Note [Kind coercions] go (FunTy ty1 ty2) = mkFunCo (go ty1) (go ty2) go (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' ty) where @@ -1083,6 +1099,7 @@ coercionKinds :: [Coercion] -> Pair [Type] coercionKinds tys = sequenceA $ map coercionKind tys getNth :: Int -> Type -> Type +-- Executing Nth getNth n ty | Just tys <- tyConAppArgs_maybe ty = ASSERT2( n < length tys, ppr n <+> ppr tys ) tys !! n getNth n ty = pprPanic "getNth" (ppr n <+> ppr ty) @@ -1095,3 +1112,9 @@ applyCo ty co | Just ty' <- coreView ty = applyCo ty' co applyCo (FunTy _ ty) _ = ty applyCo _ _ = panic "applyCo" \end{code} + +Note [Kind coercions] +~~~~~~~~~~~~~~~~~~~~~ +Kind coercions are only of the form: Refl kind. They are only used to +instantiate kind polymorphic type constructors in TyConAppCo. Remember +that kind instantiation only happens with TyConApp, not AppTy. diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 6e9abe0d3e..236185168b 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -309,58 +309,6 @@ lookupFamInstEnv where match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys -lookupFamInstEnvConflicts' - :: FamInstEnv - -> FamInst -- Putative new instance - -> [TyVar] -- Unique tyvars, matching arity of FamInst - -> [FamInstMatch] -- Conflicting matches --- E.g. when we are about to add --- f : type instance F [a] = a->a --- we do (lookupFamInstConflicts f [b]) --- to find conflicting matches --- The skolem tyvars are needed because we don't have a --- unique supply to hand --- --- Precondition: the tycon is saturated (or over-saturated) - -lookupFamInstEnvConflicts' env fam_inst skol_tvs - = lookup_fam_inst_env' my_unify False env fam tys' - where - inst_tycon = famInstTyCon fam_inst - (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts" - (tyConFamInst_maybe inst_tycon) - skol_tys = mkTyVarTys skol_tvs - tys' = substTys (zipTopTvSubst (tyConTyVars inst_tycon) skol_tys) tys - -- In example above, fam tys' = F [b] - - my_unify old_fam_inst tpl_tvs tpl_tys match_tys - = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs, - (ppr fam <+> ppr tys) $$ - (ppr tpl_tvs <+> ppr tpl_tys) ) - -- Unification will break badly if the variables overlap - -- They shouldn't because we allocate separate uniques for them - case tcUnifyTys instanceBindFun tpl_tys match_tys of - Just subst | conflicting old_fam_inst subst -> Just subst - _other -> Nothing - - -- - In the case of data family instances, any overlap is fundamentally a - -- conflict (as these instances imply injective type mappings). - -- - In the case of type family instances, overlap is admitted as long as - -- the right-hand sides of the overlapping rules coincide under the - -- overlap substitution. We require that they are syntactically equal; - -- anything else would be difficult to test for at this stage. - conflicting old_fam_inst subst - | isAlgTyCon fam = True - | otherwise = not (old_rhs `eqType` new_rhs) - where - old_tycon = famInstTyCon old_fam_inst - old_tvs = tyConTyVars old_tycon - old_rhs = mkTyConApp old_tycon (substTyVars subst old_tvs) - new_rhs = mkTyConApp inst_tycon (substTyVars subst skol_tvs) - - - - lookupFamInstEnvConflicts :: FamInstEnvs -> FamInst -- Putative new instance @@ -376,18 +324,18 @@ lookupFamInstEnvConflicts -- Precondition: the tycon is saturated (or over-saturated) lookupFamInstEnvConflicts envs fam_inst skol_tvs - = lookup_fam_inst_env my_unify False envs fam tys' + = lookup_fam_inst_env my_unify False envs fam tys1 where inst_tycon = famInstTyCon fam_inst (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts" (tyConFamInst_maybe inst_tycon) skol_tys = mkTyVarTys skol_tvs - tys' = substTys (zipTopTvSubst (tyConTyVars inst_tycon) skol_tys) tys + tys1 = substTys (zipTopTvSubst (tyConTyVars inst_tycon) skol_tys) tys -- In example above, fam tys' = F [b] my_unify old_fam_inst tpl_tvs tpl_tys match_tys - = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs, - (ppr fam <+> ppr tys) $$ + = ASSERT2( tyVarsOfTypes tys1 `disjointVarSet` tpl_tvs, + (ppr fam <+> ppr tys1) $$ (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them @@ -395,12 +343,7 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs Just subst | conflicting old_fam_inst subst -> Just subst _other -> Nothing - -- - In the case of data family instances, any overlap is fundamentally a - -- conflict (as these instances imply injective type mappings). - -- - In the case of type family instances, overlap is admitted as long as - -- the right-hand sides of the overlapping rules coincide under the - -- overlap substitution. We require that they are syntactically equal; - -- anything else would be difficult to test for at this stage. + -- Note [Family instance overlap conflicts] conflicting old_fam_inst subst | isAlgTyCon fam = True | otherwise = not (old_rhs `eqType` new_rhs) @@ -409,8 +352,29 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs old_tvs = tyConTyVars old_tycon old_rhs = mkTyConApp old_tycon (substTyVars subst old_tvs) new_rhs = mkTyConApp inst_tycon (substTyVars subst skol_tvs) + +-- This variant is called when we want to check if the conflict is only in the +-- home environment (see FamInst.addLocalFamInst) +lookupFamInstEnvConflicts' :: FamInstEnv -> FamInst -> [TyVar] -> [FamInstMatch] +lookupFamInstEnvConflicts' env fam_inst skol_tvs + = lookupFamInstEnvConflicts (emptyFamInstEnv, env) fam_inst skol_tvs \end{code} +Note [Family instance overlap conflicts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +- In the case of data family instances, any overlap is fundamentally a + conflict (as these instances imply injective type mappings). + +- In the case of type family instances, overlap is admitted as long as + the right-hand sides of the overlapping rules coincide under the + overlap substitution. eg + type instance F a Int = a + type instance F Int b = b + These two overlap on (F Int Int) but then both RHSs are Int, + so all is well. We require that they are syntactically equal; + anything else would be difficult to test for at this stage. + + While @lookupFamInstEnv@ uses a one-way match, the next function @lookupFamInstEnvConflicts@ uses two-way matching (ie, unification). This is needed to check for overlapping instances. diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index e5ef583c99..13585783e0 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -15,13 +15,14 @@ module Kind ( Kind, typeKind, -- Kinds - liftedTypeKind, unliftedTypeKind, openTypeKind, + anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind, mkArrowKind, mkArrowKinds, -- Kind constructors... - liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon, + anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, + unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, + constraintKindTyCon, -- Super Kinds tySuperKind, tySuperKindTyCon, @@ -34,24 +35,38 @@ module Kind ( -- ** Predicates on Kinds isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, - isUbxTupleKind, isArgTypeKind, isConstraintKind, isKind, isTySuperKind, - isSuperKind, + isUbxTupleKind, isArgTypeKind, isConstraintKind, isKind, + isSuperKind, noHashInKind, isLiftedTypeKindCon, isConstraintKindCon, + isAnyKind, isAnyKindCon, - isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, - isSubKindCon, + isSubArgTypeKind, tcIsSubArgTypeKind, + isSubOpenTypeKind, tcIsSubOpenTypeKind, + isSubKind, defaultKind, + isSubKindCon, tcIsSubKindCon, isSubOpenTypeKindCon, + + -- ** Functions on variables + isKiVar, splitKiTyVars, partitionKiTyVars, + kiVarsOfKind, kiVarsOfKinds, + + -- ** Promotion related functions + promoteType, isPromotableType, isPromotableKind, ) where #include "HsVersions.h" -import {-# SOURCE #-} Type (typeKind) +import {-# SOURCE #-} Type ( typeKind, substKiWith, eqKind ) import TypeRep import TysPrim import TyCon +import Var +import VarSet import PrelNames import Outputable + +import Data.List ( partition ) \end{code} %************************************************************************ @@ -61,15 +76,23 @@ import Outputable %************************************************************************ \begin{code} -isTySuperKind :: SuperKind -> Bool -isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey -isTySuperKind _ = False - ------------------- -- Lastly we need a few functions on Kinds isLiftedTypeKindCon :: TyCon -> Bool isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey + +-- This checks that its argument does not contain # or (#). +-- It is used in tcTyVarBndrs. +noHashInKind :: Kind -> Bool +noHashInKind (TyVarTy {}) = True +noHashInKind (FunTy k1 k2) = noHashInKind k1 && noHashInKind k2 +noHashInKind (ForAllTy _ ki) = noHashInKind ki +noHashInKind (TyConApp kc kis) + = not (kc `hasKey` unliftedTypeKindTyConKey) + && not (kc `hasKey` ubxTupleKindTyConKey) + && all noHashInKind kis +noHashInKind _ = panic "noHashInKind" \end{code} %************************************************************************ @@ -79,14 +102,15 @@ isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey %************************************************************************ \begin{code} --- | Essentially 'funResultTy' on kinds -kindFunResult :: Kind -> Kind -kindFunResult (FunTy _ res) = res -kindFunResult k = pprPanic "kindFunResult" (ppr k) +-- | Essentially 'funResultTy' on kinds handling pi-types too +kindFunResult :: Kind -> KindOrType -> Kind +kindFunResult (FunTy _ res) _ = res +kindFunResult (ForAllTy kv res) arg = substKiWith [kv] [arg] res +kindFunResult k _ = pprPanic "kindFunResult" (ppr k) -kindAppResult :: Kind -> [arg] -> Kind +kindAppResult :: Kind -> [Type] -> Kind kindAppResult k [] = k -kindAppResult k (_:as) = kindAppResult (kindFunResult k) as +kindAppResult k (a:as) = kindAppResult (kindFunResult k a) as -- | Essentially 'splitFunTys' on kinds splitKindFunTys :: Kind -> ([Kind],Kind) @@ -110,12 +134,21 @@ splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k) -- Actually this function works fine on data types too, -- but they'd always return '*', so we never need to ask synTyConResKind :: TyCon -> Kind -synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon) +synTyConResKind tycon = kindAppResult (tyConKind tycon) (map mkTyVarTy (tyConTyVars tycon)) -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind, isConstraintKind :: Kind -> Bool +isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind, + isConstraintKind, isAnyKind :: Kind -> Bool + isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon, - isUnliftedTypeKindCon, isSubArgTypeKindCon, isConstraintKindCon :: TyCon -> Bool + isUnliftedTypeKindCon, isSubArgTypeKindCon, tcIsSubArgTypeKindCon, + isSubOpenTypeKindCon, tcIsSubOpenTypeKindCon, isConstraintKindCon, + isAnyKindCon :: TyCon -> Bool + +isAnyKindCon tc = tyConUnique tc == anyKindTyConKey + +isAnyKind (TyConApp tc _) = isAnyKindCon tc +isAnyKind _ = False isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey @@ -142,16 +175,31 @@ isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey isConstraintKind (TyConApp tc _) = isConstraintKindCon tc isConstraintKind _ = False -isSubOpenTypeKind :: Kind -> Bool --- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow) -isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) ) - ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) ) - False -isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True -isSubOpenTypeKind other = ASSERT( isKind other ) False - -- This is a conservative answer - -- It matters in the call to isSubKind in - -- checkExpectedKind. + +-- Subkinding +-- The tc variants are used during type-checking, where we don't want the +-- Constraint kind to be a subkind of anything +-- After type-checking (in core), Constraint is a subkind of argTypeKind +isSubOpenTypeKind, tcIsSubOpenTypeKind :: Kind -> Bool +-- ^ True of any sub-kind of OpenTypeKind +isSubOpenTypeKind (TyConApp kc []) = isSubOpenTypeKindCon kc +isSubOpenTypeKind _ = False + +-- ^ True of any sub-kind of OpenTypeKind +tcIsSubOpenTypeKind (TyConApp kc []) = tcIsSubOpenTypeKindCon kc +tcIsSubOpenTypeKind _ = False + +isSubOpenTypeKindCon kc + | isSubArgTypeKindCon kc = True + | isUbxTupleKindCon kc = True + | isOpenTypeKindCon kc = True + | otherwise = False + +tcIsSubOpenTypeKindCon kc + | tcIsSubArgTypeKindCon kc = True + | isUbxTupleKindCon kc = True + | isOpenTypeKindCon kc = True + | otherwise = False isSubArgTypeKindCon kc | isUnliftedTypeKindCon kc = True @@ -160,11 +208,18 @@ isSubArgTypeKindCon kc | isConstraintKindCon kc = True | otherwise = False -isSubArgTypeKind :: Kind -> Bool +tcIsSubArgTypeKindCon kc + | isConstraintKindCon kc = False + | otherwise = isSubArgTypeKindCon kc + +isSubArgTypeKind, tcIsSubArgTypeKind :: Kind -> Bool -- ^ True of any sub-kind of ArgTypeKind isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc isSubArgTypeKind _ = False +tcIsSubArgTypeKind (TyConApp kc []) = tcIsSubArgTypeKindCon kc +tcIsSubArgTypeKind _ = False + -- | Is this a super-kind (i.e. a type-of-kinds)? isSuperKind :: Type -> Bool isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc @@ -176,25 +231,44 @@ isKind k = isSuperKind (typeKind k) isSubKind :: Kind -> Kind -> Bool -- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@ -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2 -isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2) -isSubKind _ _ = False + +isSubKind (FunTy a1 r1) (FunTy a2 r2) + = (a2 `isSubKind` a1) && (r1 `isSubKind` r2) + +isSubKind k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) + | isPromotedTypeTyCon kc1 || isPromotedTypeTyCon kc2 + -- handles promoted kinds (List *, Nat, etc.) + = eqKind k1 k2 + + | isSuperKindTyCon kc1 || isSuperKindTyCon kc2 + -- handles BOX + = ASSERT2( isSuperKindTyCon kc2 && null k1s && null k2s, ppr kc1 <+> ppr kc2 ) + True + + | otherwise = -- handles usual kinds (*, #, (#), etc.) + ASSERT2( null k1s && null k2s, ppr k1 <+> ppr k2 ) + kc1 `isSubKindCon` kc2 + + +isSubKind k1 k2 = eqKind k1 k2 isSubKindCon :: TyCon -> TyCon -> Bool -- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@ isSubKindCon kc1 kc2 - | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True - | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True - | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True - | isConstraintKindCon kc1 && isConstraintKindCon kc2 = True - | isOpenTypeKindCon kc2 = True - -- we already know kc1 is not a fun, its a TyCon - | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True + | kc1 == kc2 = True + | isSubArgTypeKindCon kc1 && isArgTypeKindCon kc2 = True + | isSubOpenTypeKindCon kc1 && isOpenTypeKindCon kc2 = True | otherwise = False +tcIsSubKindCon :: TyCon -> TyCon -> Bool +tcIsSubKindCon kc1 kc2 + | kc1 == kc2 = True + | isConstraintKindCon kc1 || isConstraintKindCon kc2 = False + | otherwise = isSubKindCon kc1 kc2 + defaultKind :: Kind -> Kind --- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more --- information on what that means +-- ^ Used when generalising: default kind ? and ?? to *. +-- See "Type#kind_subtyping" for more information on what that means -- When we generalise, we make generic type variables whose kind is -- simple (* or *->* etc). So generic type variables (other than @@ -206,9 +280,78 @@ defaultKind :: Kind -> Kind -- Not -- f :: forall (a::??). a -> Bool -- because that would allow a call like (f 3#) as well as (f True), ---and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr. -defaultKind k +-- and the calling conventions differ. +-- This defaulting is done in TcMType.zonkTcTyVarBndr. +defaultKind k | isSubOpenTypeKind k = liftedTypeKind - | isSubArgTypeKind k = liftedTypeKind - | otherwise = k -\end{code}
\ No newline at end of file + | otherwise = k + +splitKiTyVars :: [TyVar] -> ([KindVar], [TyVar]) +-- Precondition: kind variables should precede type variables +-- Postcondition: appending the two result lists gives the input! +splitKiTyVars = span (isSuperKind . tyVarKind) + +partitionKiTyVars :: [TyVar] -> ([KindVar], [TyVar]) +partitionKiTyVars = partition (isSuperKind . tyVarKind) + +-- Checks if this "type or kind" variable is a kind variable +isKiVar :: TyVar -> Bool +isKiVar v = isSuperKind (varType v) + +-- Returns the free kind variables in a kind +kiVarsOfKind :: Kind -> VarSet +kiVarsOfKind = tyVarsOfType + +kiVarsOfKinds :: [Kind] -> VarSet +kiVarsOfKinds = tyVarsOfTypes + +-- Datatype promotion +isPromotableType :: Type -> Bool +isPromotableType = go emptyVarSet + where + go vars (TyConApp tc tys) = ASSERT( not (isPromotedDataTyCon tc) ) all (go vars) tys + go vars (FunTy arg res) = all (go vars) [arg,res] + go vars (TyVarTy tvar) = tvar `elemVarSet` vars + go vars (ForAllTy tvar ty) = isPromotableTyVar tvar && go (vars `extendVarSet` tvar) ty + go _ _ = panic "isPromotableType" -- argument was not kind-shaped + +isPromotableTyVar :: TyVar -> Bool +isPromotableTyVar = isLiftedTypeKind . varType + +-- | Promotes a type to a kind. Assumes the argument is promotable. +promoteType :: Type -> Kind +promoteType (TyConApp tc tys) = mkTyConApp (mkPromotedTypeTyCon tc) + (map promoteType tys) + -- T t1 .. tn ~~> 'T k1 .. kn where ti ~~> ki +promoteType (FunTy arg res) = mkArrowKind (promoteType arg) (promoteType res) + -- t1 -> t2 ~~> k1 -> k2 where ti ~~> ki +promoteType (TyVarTy tvar) = mkTyVarTy (promoteTyVar tvar) + -- a :: * ~~> a :: BOX +promoteType (ForAllTy tvar ty) = ForAllTy (promoteTyVar tvar) (promoteType ty) + -- forall (a :: *). t ~~> forall (a :: BOX). k where t ~~> k +promoteType _ = panic "promoteType" -- argument was not kind-shaped + +promoteTyVar :: TyVar -> KindVar +promoteTyVar tvar = mkKindVar (tyVarName tvar) tySuperKind + +-- If kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ] +isPromotableKind :: Kind -> Maybe Int +isPromotableKind kind = + let (args, res) = splitKindFunTys kind in + if all isLiftedTypeKind (res:args) + then Just $ length args + else Nothing + +{- Note [Promoting a Type to a Kind] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only promote the followings. +- Type variables: a +- Fully applied arrow types: tau -> sigma +- Fully applied type constructors of kind: + n >= 0 + /-----------\ + * -> ... -> * -> * +- Polymorphic types over type variables of kind star: + forall (a::*). tau +-} +\end{code} diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 6db746bc76..f8745e62fb 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -36,7 +36,8 @@ module TyCon( mkSynTyCon, mkSuperKindTyCon, mkForeignTyCon, - mkAnyTyCon, + mkPromotedDataTyCon, + mkPromotedTypeTyCon, -- ** Predicates on TyCons isAlgTyCon, @@ -46,7 +47,8 @@ module TyCon( isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isSynTyCon, isClosedSynTyCon, isSuperKindTyCon, isDecomposableTyCon, - isForeignTyCon, isAnyTyCon, tyConHasKind, + isForeignTyCon, tyConHasKind, + isPromotedDataTyCon, isPromotedTypeTyCon, isInjectiveTyCon, isDataTyCon, isProductTyCon, isEnumerationTyCon, @@ -90,7 +92,7 @@ module TyCon( #include "HsVersions.h" import {-# SOURCE #-} TypeRep ( Kind, Type, PredType ) -import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) +import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon, dataConName ) import {-# SOURCE #-} IParam ( ipTyConName ) import Var @@ -341,7 +343,7 @@ data TyCon tc_kind :: Kind, tyConArity :: Arity, - tyConTyVars :: [TyVar], -- ^ The type variables used in the type constructor. + tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the type constructor. -- Invariant: length tyvars = arity -- Precisely, this list scopes over: -- @@ -427,19 +429,6 @@ data TyCon -- holds the name of the imported thing } - -- | Any types. Like tuples, this is a potentially-infinite family of TyCons - -- one for each distinct Kind. They have no values at all. - -- Because there are infinitely many of them (like tuples) they are - -- defined in GHC.Prim and have names like "Any(*->*)". - -- Their Unique is derived from the OccName. - -- See Note [Any types] in TysPrim - | AnyTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind -- Never = *; that is done via PrimTyCon - -- See Note [Any types] in TysPrim - } - -- | Super-kinds. These are "kinds-of-kinds" and are never seen in -- Haskell source programs. There are only two super-kinds: TY (aka -- "box"), which is the super-kind of kinds that construct types @@ -451,6 +440,23 @@ data TyCon tyConUnique :: Unique, tyConName :: Name } + + -- | Represents promoted data constructor. + | PromotedDataTyCon { -- See Note [Promoted data constructors] + tyConUnique :: Unique, -- ^ Same Unique as the data constructor + tyConName :: Name, -- ^ Same Name as the data constructor + tc_kind :: Kind, -- ^ Translated type of the data constructor + dataCon :: DataCon -- ^ Corresponding data constructor + } + + -- | Represents promoted type constructor. + | PromotedTypeTyCon { + tyConUnique :: Unique, -- ^ Same Unique as the type constructor + tyConName :: Name, -- ^ Same Name as the type constructor + tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times + ty_con :: TyCon -- ^ Corresponding type constructor + } + deriving Typeable -- | Names of the fields in an algebraic record type @@ -551,6 +557,7 @@ data TyConParent NoParentTyCon -- | Type constructors representing a class dictionary. + -- See Note [ATyCon for classes] in TypeRep | ClassTyCon Class -- INVARIANT: the classTyCon of this Class is the current tycon @@ -619,6 +626,34 @@ data SynTyConRhs | SynFamilyTyCon \end{code} +Note [Promoted data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A data constructor can be promoted to become a type constructor, +via the PromotedDataTyCon alternative in TyCon. + +* Only "vanilla" data constructors are promoted; ones with no GADT + stuff, no existentials, etc. We might generalise this later. + +* The TyCon promoted from a DataCon has the *same* Name and Unique as + the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78, + say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) + +* The *kind* of a promoted DataCon may be polymorphic. Example: + type of DataCon Just :: forall (a:*). a -> Maybe a + kind of (promoted) tycon Just :: forall (a:box). a -> Maybe a + The kind is not identical to the type, because of the */box + kind signature on the forall'd variable; so the tc_kind field of + PromotedDataTyCon is not identical to the dataConUserType of the + DataCon. But it's the same modulo changing the variable kinds, + done by Kind.promoteType. + +* Small note: We promote the *user* type of the DataCon. Eg + data T = MkT {-# UNPACK #-} !(Bool, Bool) + The promoted kind is + MkT :: (Bool,Bool) -> T + *not* + MkT :: Bool -> Bool -> T + Note [Enumeration types] ~~~~~~~~~~~~~~~~~~~~~~~~ We define datatypes with no constructors to *not* be @@ -933,12 +968,6 @@ mkSynTyCon name kind tyvars rhs parent synTcParent = parent } -mkAnyTyCon :: Name -> Kind -> TyCon -mkAnyTyCon name kind - = AnyTyCon { tyConName = name, - tc_kind = kind, - tyConUnique = nameUnique name } - -- | Create a super-kind 'TyCon' mkSuperKindTyCon :: Name -> TyCon -- Super kinds always have arity zero mkSuperKindTyCon name @@ -946,6 +975,27 @@ mkSuperKindTyCon name tyConName = name, tyConUnique = nameUnique name } + +-- | Create a promoted data constructor 'TyCon' +mkPromotedDataTyCon :: DataCon -> Name -> Unique -> Kind -> TyCon +mkPromotedDataTyCon con name unique kind + = PromotedDataTyCon { + tyConName = name, + tyConUnique = unique, + tc_kind = kind, + dataCon = con + } + +-- | Create a promoted type constructor 'TyCon' +mkPromotedTypeTyCon :: TyCon -> TyCon +mkPromotedTypeTyCon con + = PromotedTypeTyCon { + tyConName = getName con, + tyConUnique = getUnique con, + tyConArity = tyConArity con, + ty_con = con + } + \end{code} \begin{code} @@ -1016,6 +1066,7 @@ isDistinctTyCon (AlgTyCon {algTcRhs = rhs}) = isDistinctAlgRhs rhs isDistinctTyCon (FunTyCon {}) = True isDistinctTyCon (TupleTyCon {}) = True isDistinctTyCon (PrimTyCon {}) = True +isDistinctTyCon (PromotedDataTyCon {}) = True isDistinctTyCon _ = False isDistinctAlgRhs :: AlgTyConRhs -> Bool @@ -1178,10 +1229,15 @@ isSuperKindTyCon :: TyCon -> Bool isSuperKindTyCon (SuperKindTyCon {}) = True isSuperKindTyCon _ = False --- | Is this an AnyTyCon? -isAnyTyCon :: TyCon -> Bool -isAnyTyCon (AnyTyCon {}) = True -isAnyTyCon _ = False +-- | Is this a PromotedDataTyCon? +isPromotedDataTyCon :: TyCon -> Bool +isPromotedDataTyCon (PromotedDataTyCon {}) = True +isPromotedDataTyCon _ = False + +-- | Is this a PromotedTypeTyCon? +isPromotedTypeTyCon :: TyCon -> Bool +isPromotedTypeTyCon (PromotedTypeTyCon {}) = True +isPromotedTypeTyCon _ = False -- | Identifies implicit tycons that, in particular, do not go into interface -- files (because they are implicitly reconstructed when the interface is @@ -1249,12 +1305,12 @@ expand tvs rhs tys \begin{code} tyConKind :: TyCon -> Kind -tyConKind (FunTyCon { tc_kind = k }) = k -tyConKind (AlgTyCon { tc_kind = k }) = k -tyConKind (TupleTyCon { tc_kind = k }) = k -tyConKind (SynTyCon { tc_kind = k }) = k -tyConKind (PrimTyCon { tc_kind = k }) = k -tyConKind (AnyTyCon { tc_kind = k }) = k +tyConKind (FunTyCon { tc_kind = k }) = k +tyConKind (AlgTyCon { tc_kind = k }) = k +tyConKind (TupleTyCon { tc_kind = k }) = k +tyConKind (SynTyCon { tc_kind = k }) = k +tyConKind (PrimTyCon { tc_kind = k }) = k +tyConKind (PromotedDataTyCon { tc_kind = k }) = k tyConKind tc = pprPanic "tyConKind" (ppr tc) -- SuperKindTyCon and CoTyCon tyConHasKind :: TyCon -> Bool @@ -1458,7 +1514,8 @@ instance Uniquable TyCon where getUnique tc = tyConUnique tc instance Outputable TyCon where - ppr tc = ppr (getName tc) + ppr (PromotedDataTyCon {dataCon = dc}) = quote (ppr (dataConName dc)) + ppr tc = ppr (getName tc) instance NamedThing TyCon where getName = tyConName diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 615952fc4a..0557ab60bd 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -21,7 +21,7 @@ module Type ( -- $type_classification -- $representation_types - TyThing(..), Type, PredType, ThetaType, + TyThing(..), Type, KindOrType, PredType, ThetaType, Var, TyVar, isTyVar, -- ** Constructing and deconstructing types @@ -34,11 +34,12 @@ module Type ( splitFunTys, splitFunTysN, funResultTy, funArgTy, zipFunTys, - mkTyConApp, mkTyConTy, + mkTyConApp, mkTyConTy, tyConAppTyCon_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, splitTyConApp_maybe, splitTyConApp, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, + mkForAllArrowKinds, applyTy, applyTys, applyTysD, isForAllTy, dropForAlls, -- (Newtypes) @@ -62,7 +63,7 @@ module Type ( funTyCon, -- ** Predicates on types - isTyVarTy, isFunTy, isDictTy, isPredTy, + isTyVarTy, isFunTy, isDictTy, isPredTy, isKindTy, -- (Lifting and boxity) isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, @@ -70,24 +71,25 @@ module Type ( -- * Main data types representing Kinds -- $kind_subtyping - Kind, SimpleKind, KindVar, + Kind, SimpleKind, MetaKindVar, -- ** Finding the kind of a type typeKind, -- ** Common Kinds and SuperKinds - liftedTypeKind, unliftedTypeKind, openTypeKind, + anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind, tySuperKind, -- ** Common Kind type constructors liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon, + anyKindTyCon, -- * Type free variables tyVarsOfType, tyVarsOfTypes, expandTypeSynonyms, - typeSize, + typeSize, varSetElemsKvsFirst, sortQuantVars, -- * Type comparison eqType, eqTypeX, eqTypes, cmpType, cmpTypes, @@ -121,17 +123,16 @@ module Type ( isInScope, composeTvSubst, zipTyEnv, isEmptyTvSubst, unionTvSubst, - -- ** Performing substitution on types + -- ** Performing substitution on types and kinds substTy, substTys, substTyWith, substTysWith, substTheta, substTyVar, substTyVars, substTyVarBndr, - cloneTyVarBndr, deShadowTy, lookupTyVar, + cloneTyVarBndr, deShadowTy, lookupTyVar, + substKiWith, substKisWith, -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, - pprKind, pprParendKind, - - pprSourceTyCon + pprKind, pprParendKind, pprSourceTyCon, ) where #include "HsVersions.h" @@ -139,7 +140,7 @@ module Type ( -- We import the representation and primitive functions from TypeRep. -- Many things are reexported, but not the representation! -import Kind ( kindAppResult, kindFunResult, isTySuperKind, isSubOpenTypeKind ) +import Kind import TypeRep -- friends: @@ -151,7 +152,7 @@ import Class import TyCon import TysPrim import {-# SOURCE #-} TysWiredIn ( eqTyCon, mkBoxedTupleTy ) -import PrelNames ( eqTyConKey, eqPrimTyConKey ) +import PrelNames ( eqTyConKey ) -- others import {-# SOURCE #-} IParam ( ipTyCon ) @@ -674,6 +675,13 @@ mkForAllTy tyvar ty mkForAllTys :: [TyVar] -> Type -> Type mkForAllTys tyvars ty = foldr ForAllTy ty tyvars +mkForAllArrowKinds :: [TyVar] -> Kind -> Kind +-- mkForAllArrowKinds [k1, k2, (a:k1 -> *)] k2 +-- returns forall k1 k2. (k1 -> *) -> k2 +mkForAllArrowKinds ktvs res = + mkForAllTys kvs $ mkArrowKinds (map tyVarKind tvs) res + where (kvs, tvs) = splitKiTyVars ktvs + isForAllTy :: Type -> Bool isForAllTy (ForAllTy _ _) = True isForAllTy _ = False @@ -715,12 +723,12 @@ applyTy, applyTys -- -- We use @applyTys type-of-f [t1,t2]@ to compute the type of the expression. -- Panics if no application is possible. -applyTy :: Type -> Type -> Type +applyTy :: Type -> KindOrType -> Type applyTy ty arg | Just ty' <- coreView ty = applyTy ty' arg applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty applyTy _ _ = panic "applyTy" -applyTys :: Type -> [Type] -> Type +applyTys :: Type -> [KindOrType] -> Type -- ^ This function is interesting because: -- -- 1. The function may have more for-alls than there are args @@ -731,12 +739,12 @@ applyTys :: Type -> [Type] -> Type -- -- > applyTys (forall a.a) [forall b.b, Int] -- --- This really can happen, via dressing up polymorphic types with newtype --- clothing. Here's an example: --- --- > newtype R = R (forall a. a->a) --- > foo = case undefined :: R of --- > R f -> f () +-- This really can happen, but only (I think) in situations involving +-- undefined. For example: +-- undefined :: forall a. a +-- Term: undefined @(forall b. b->b) @Int +-- This term should have type (Int -> Int), but notice that +-- there are more type args than foralls in 'undefined's type. applyTys ty args = applyTysD empty ty args @@ -776,7 +784,12 @@ noParenPred :: PredType -> Bool noParenPred p = isClassPred p || isEqPred p isPredTy :: Type -> Bool -isPredTy ty = typeKind ty `eqKind` constraintKind +isPredTy ty + | isSuperKind ty = False + | otherwise = typeKind ty `eqKind` constraintKind + +isKindTy :: Type -> Bool +isKindTy = isSuperKind . typeKind isClassPred, isEqPred, isIPPred :: PredType -> Bool isClassPred ty = case tyConAppTyCon_maybe ty of @@ -796,10 +809,16 @@ Make PredTypes \begin{code} -- | Creates a type equality predicate mkEqPred :: (Type, Type) -> PredType -mkEqPred (ty1, ty2) = TyConApp eqTyCon [ty1, ty2] +mkEqPred (ty1, ty2) + -- IA0_TODO: The caller should give the kind. + = TyConApp eqTyCon [k, ty1, ty2] + where k = defaultKind (typeKind ty1) mkPrimEqType :: (Type, Type) -> Type -mkPrimEqType (ty1, ty2) = TyConApp eqPrimTyCon [ty1, ty2] +mkPrimEqType (ty1, ty2) + -- IA0_TODO: The caller should give the kind. + = TyConApp eqPrimTyCon [k, ty1, ty2] + where k = defaultKind (typeKind ty1) \end{code} --------------------- Implicit parameters --------------------------------- @@ -877,7 +896,7 @@ predTypePredTree ev_ty = case splitTyConApp_maybe ev_ty of Just (tc, tys) | Just clas <- tyConClass_maybe tc -> ClassPred clas tys Just (tc, tys) | tc `hasKey` eqTyConKey - , let [ty1, ty2] = tys + , let [_, ty1, ty2] = tys -> EqPred ty1 ty2 Just (tc, tys) | Just ip <- tyConIP_maybe tc , let [ty] = tys @@ -905,7 +924,7 @@ getEqPredTys ty = case getEqPredTys_maybe ty of getEqPredTys_maybe :: PredType -> Maybe (Type, Type) getEqPredTys_maybe ty = case splitTyConApp_maybe ty of - Just (tc, [ty1, ty2]) | tc `hasKey` eqTyConKey -> Just (ty1, ty2) + Just (tc, [_, ty1, ty2]) | tc `hasKey` eqTyConKey -> Just (ty1, ty2) _ -> Nothing getIPPredTy_maybe :: PredType -> Maybe (IPName Name, Type) @@ -927,6 +946,26 @@ typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 typeSize (ForAllTy _ t) = 1 + typeSize t typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) + +varSetElemsKvsFirst :: VarSet -> [TyVar] +-- {k1,a,k2,b} --> [k1,k2,a,b] +varSetElemsKvsFirst set = uncurry (++) $ partitionKiTyVars (varSetElems set) + +sortQuantVars :: [Var] -> [Var] +-- Sort the variables so the true kind then type variables come first +sortQuantVars = sortLe le + where + v1 `le` v2 = case (is_tv v1, is_tv v2) of + (True, False) -> True + (False, True) -> False + (True, True) -> + case (is_kv v1, is_kv v2) of + (True, False) -> True + (False, True) -> False + _ -> v1 <= v2 -- Same family + (False, False) -> v1 <= v2 + is_tv v = isTyVar v + is_kv v = isSuperKind (tyVarKind v) \end{code} @@ -1158,6 +1197,29 @@ cmpTypesX _ [] _ = LT cmpTypesX _ _ [] = GT \end{code} +Note [cmpTypeX] +~~~~~~~~~~~~~~~ + +When we compare foralls, we should look at the kinds. But if we do so, +we get a corelint error like the following (in +libraries/ghc-prim/GHC/PrimopWrappers.hs): + + Binder's type: forall (o_abY :: *). + o_abY + -> GHC.Prim.State# GHC.Prim.RealWorld + -> GHC.Prim.State# GHC.Prim.RealWorld + Rhs type: forall (a_12 :: ?). + a_12 + -> GHC.Prim.State# GHC.Prim.RealWorld + -> GHC.Prim.State# GHC.Prim.RealWorld + +This is why we don't look at the kind. Maybe we should look if the +kinds are compatible. + +-- cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) +-- = cmpTypeX env (tyVarKind tv1) (tyVarKind tv2) `thenCmp` +-- cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 + %************************************************************************ %* * Type substitutions @@ -1308,7 +1370,7 @@ instance Outputable TvSubst where %************************************************************************ %* * - Performing type substitutions + Performing type or kind substitutions %* * %************************************************************************ @@ -1319,12 +1381,18 @@ substTyWith :: [TyVar] -> [Type] -> Type -> Type substTyWith tvs tys = ASSERT( length tvs == length tys ) substTy (zipOpenTvSubst tvs tys) +substKiWith :: [KindVar] -> [Kind] -> Kind -> Kind +substKiWith = substTyWith + -- | Type substitution making use of an 'TvSubst' that -- is assumed to be open, see 'zipOpenTvSubst' substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] substTysWith tvs tys = ASSERT( length tvs == length tys ) substTys (zipOpenTvSubst tvs tys) +substKisWith :: [KindVar] -> [Kind] -> [Kind] -> [Kind] +substKisWith = substTysWith + -- | Substitute within a 'Type' substTy :: TvSubst -> Type -> Type substTy subst ty | isEmptyTvSubst subst = ty @@ -1397,7 +1465,9 @@ substTyVarBndr subst@(TvSubst in_scope tenv) old_var _no_capture = not (new_var `elemVarSet` tyVarsOfTypes (varEnvElts tenv)) -- Assertion check that we are not capturing something in the substitution - no_change = new_var == old_var + old_ki = tyVarKind old_var + no_kind_change = isEmptyVarSet (tyVarsOfType old_ki) -- verify that kind is closed + no_change = no_kind_change && (new_var == old_var) -- no_change means that the new_var is identical in -- all respects to the old_var (same unique, same kind) -- See Note [Extending the TvSubst] @@ -1408,7 +1478,8 @@ substTyVarBndr subst@(TvSubst in_scope tenv) old_var -- (\x.e) with id_subst = [x |-> e'] -- Here we must simply zap the substitution for x - new_var = uniqAway in_scope old_var + new_var | no_kind_change = uniqAway in_scope old_var + | otherwise = uniqAway in_scope $ updateTyVarKind (substTy subst) old_var -- The uniqAway part makes sure the new variable is not already in scope cloneTyVarBndr :: TvSubst -> TyVar -> Unique -> (TvSubst, TyVar) @@ -1454,9 +1525,9 @@ Kinds -- -- Where in the last example @t :: ??@ (i.e. is not an unboxed tuple) -type KindVar = TyVar -- invariant: KindVar will always be a - -- TcTyVar with details MetaTv TauTv ... --- kind var constructors and functions are in TcType +type MetaKindVar = TyVar -- invariant: MetaKindVar will always be a + -- TcTyVar with details MetaTv TauTv ... +-- meta kind var constructors and functions are in TcType type SimpleKind = Kind \end{code} @@ -1469,13 +1540,13 @@ type SimpleKind = Kind \begin{code} typeKind :: Type -> Kind -typeKind ty@(TyConApp tc tys) - = ASSERT2( not (tc `hasKey` eqPrimTyConKey) || length tys == 2, ppr ty ) - -- Assertion checks for unsaturated application of ~# - -- See Note [The ~# TyCon] in TysPrim - kindAppResult (tyConKind tc) tys +typeKind (TyConApp tc tys) + | isPromotedTypeTyCon tc + = ASSERT( tyConArity tc == length tys ) tySuperKind + | otherwise + = kindAppResult (tyConKind tc) tys -typeKind (AppTy fun _) = kindFunResult (typeKind fun) +typeKind (AppTy fun arg) = kindAppResult (typeKind fun) [arg] typeKind (ForAllTy _ ty) = typeKind ty typeKind (TyVarTy tyvar) = tyVarKind tyvar typeKind (FunTy _arg res) @@ -1484,8 +1555,8 @@ typeKind (FunTy _arg res) -- The only things that can be after a function arrow are -- (a) types (of kind openTypeKind or its sub-kinds) -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) - | isTySuperKind k = k - | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind + | isSuperKind k = k + | otherwise = ASSERT( isSubOpenTypeKind k ) liftedTypeKind where k = typeKind res diff --git a/compiler/types/Type.lhs-boot b/compiler/types/Type.lhs-boot index c9378fb214..c2d2dec093 100644 --- a/compiler/types/Type.lhs-boot +++ b/compiler/types/Type.lhs-boot @@ -1,9 +1,12 @@ \begin{code} module Type where import {-# SOURCE #-} TypeRep( Type, Kind ) +import Var noParenPred :: Type -> Bool isPredTy :: Type -> Bool typeKind :: Type -> Kind +substKiWith :: [KindVar] -> [Kind] -> Kind -> Kind +eqKind :: Kind -> Kind -> Bool \end{code} diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index df3c9cab77..ced5e961d7 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -18,7 +18,7 @@ module TypeRep ( TyThing(..), Type(..), - Kind, SuperKind, + KindOrType, Kind, SuperKind, PredType, ThetaType, -- Synonyms -- Functions over types @@ -117,7 +117,7 @@ to cut all loops. The other members of the loop may be marked 'non-recursive'. \begin{code} -- | The key representation of types within the compiler data Type - = TyVarTy TyVar -- ^ Vanilla type variable (*never* a coercion variable) + = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) | AppTy Type @@ -130,7 +130,7 @@ data Type | TyConApp TyCon - [Type] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. + [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. -- Invariant: saturated appliations of 'FunTyCon' must -- use 'FunTy' and saturated synonyms must use their own -- constructors. However, /unsaturated/ 'FunTyCon's @@ -151,11 +151,13 @@ data Type -- See Note [Equality-constrained types] | ForAllTy - TyVar -- Type variable + Var -- Type or kind variable Type -- ^ A polymorphic type deriving (Data.Data, Data.Typeable) +type KindOrType = Type -- See Note [Arguments to type constructors] + -- | The key type representing kinds in the compiler. -- Invariant: a kind is always in one of these forms: -- @@ -172,6 +174,30 @@ type Kind = Type type SuperKind = Type \end{code} + +Note [Arguments to type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because of kind polymorphism, in addition to type application we now +have kind instantiation. We reuse the same notations to do so. + +For example: + + Just (* -> *) Maybe + Right * Nat Zero + +are represented by: + + TyConApp (PromotedDataCon Just) [* -> *, Maybe] + TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] + +Important note: Nat is used as a *kind* and not as a type. This can be +confusing, since type-level Nat and kind-level Nat are identical. We +use the kind of (PromotedDataCon Right) to know if its arguments are +kinds or types. + +This kind instantiation only happens in TyConApp currently. + + Note [Equality-constrained types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The type forall ab. (a ~ [b]) => blah @@ -266,9 +292,12 @@ isLiftedTypeKind _ = False %* * %************************************************************************ -\begin{code} +\begin{code} tyVarsOfType :: Type -> VarSet -- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym +-- tyVarsOfType returns only the free *type* variables of a type +-- For example, tyVarsOfType (a::k) returns {a}, not including the +-- kind variable {k} tyVarsOfType (TyVarTy v) = unitVarSet v tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res @@ -289,13 +318,22 @@ Despite the fact that DataCon has to be imported via a hi-boot route, this module seems the right place for TyThing, because it's needed for funTyCon and all the types in TysPrim. +Note [ATyCon for classes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Both classes and type constructors are represented in the type environment +as ATyCon. You can tell the difference, and get to the class, with + isClassTyCon :: TyCon -> Bool + tyConClass_maybe :: TyCon -> Maybe Class +The Class and its associated TyCon have the same Name. + \begin{code} -- | A typecheckable-thing, essentially anything that has a name -data TyThing = AnId Id - | ADataCon DataCon - | ATyCon TyCon - | ACoAxiom CoAxiom - deriving (Eq, Ord) +data TyThing + = AnId Id + | ADataCon DataCon + | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] + | ACoAxiom CoAxiom + deriving (Eq, Ord) instance Outputable TyThing where ppr = pprTyThing @@ -343,12 +381,13 @@ instance NamedThing TyThing where -- Can't put this with the type -- 3. The substition is only applied ONCE! This is because -- in general such application will not reached a fixed point. data TvSubst - = TvSubst InScopeSet -- The in-scope type variables - TvSubstEnv -- Substitution of types + = TvSubst InScopeSet -- The in-scope type and kind variables + TvSubstEnv -- Substitutes both type and kind variables -- See Note [Apply Once] -- and Note [Extending the TvSubstEnv] -- | A substitition of 'Type's for 'TyVar's +-- and 'Kind's for 'KindVar's type TvSubstEnv = TyVarEnv Type -- A TvSubstEnv is used both inside a TvSubst (with the apply-once -- invariant discussed in Note [Apply Once]), and also independently @@ -592,7 +631,7 @@ pprTcApp p pp tc tys = tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys))) | tc `hasKey` eqTyConKey -- We need to special case the type equality TyCon because -- its not a SymOcc so won't get printed infix - , [ty1,ty2] <- tys + , [_, ty1,ty2] <- tys = pprInfixApp p pp (getName tc) ty1 ty2 | otherwise = pprTypeNameApp p pp (getName tc) tys diff --git a/compiler/types/TypeRep.lhs-boot b/compiler/types/TypeRep.lhs-boot index 05c9d9b7cd..aef7067ca7 100644 --- a/compiler/types/TypeRep.lhs-boot +++ b/compiler/types/TypeRep.lhs-boot @@ -8,6 +8,7 @@ data TyThing type PredType = Type type Kind = Type +type SuperKind = Type instance Outputable Type \end{code} diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 575bcfbeea..9a8cafc9ec 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -41,8 +41,6 @@ import ErrUtils import Util import Maybes import FastString - -import Control.Monad (guard) \end{code} @@ -175,7 +173,7 @@ match menv subst (TyVarTy tv1) ty2 | tv1' `elemVarSet` me_tmpls menv = if any (inRnEnvR rn_env) (varSetElems (tyVarsOfType ty2)) then Nothing -- Occurs check - else do { subst1 <- match_kind menv subst tv1 ty2 + else do { subst1 <- match_kind menv subst (tyVarKind tv1) (typeKind ty2) -- Note [Matching kinds] ; return (extendVarEnv subst1 tv1' ty2) } @@ -188,7 +186,8 @@ match menv subst (TyVarTy tv1) ty2 tv1' = rnOccL rn_env tv1 match menv subst (ForAllTy tv1 ty1) (ForAllTy tv2 ty2) - = match menv' subst ty1 ty2 + = do { subst' <- match_kind menv subst (tyVarKind tv1) (tyVarKind tv2) + ; match menv' subst' ty1 ty2 } where -- Use the magic of rnBndr2 to go under the binders menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 } @@ -207,11 +206,15 @@ match _ _ _ _ = Nothing -------------- -match_kind :: MatchEnv -> TvSubstEnv -> TyVar -> Type -> Maybe TvSubstEnv +match_kind :: MatchEnv -> TvSubstEnv -> Kind -> Kind -> Maybe TvSubstEnv -- Match the kind of the template tyvar with the kind of Type -- Note [Matching kinds] -match_kind _ subst tv ty - = guard (typeKind ty `isSubKind` tyVarKind tv) >> return subst +match_kind menv subst k1 k2 + | k2 `isSubKind` k1 + = return subst + + | otherwise + = match menv subst k1 k2 -- Note [Matching kinds] -- ~~~~~~~~~~~~~~~~~~~~~ @@ -509,25 +512,29 @@ uUnrefined subst tv1 ty2 (TyVarTy tv2) | Just ty' <- lookupVarEnv subst tv2 = uUnrefined subst tv1 ty' ty' + | otherwise -- So both are unrefined; next, see if the kinds force the direction - | eqKind k1 k2 -- Can update either; so check the bind-flags - = do { b1 <- tvBindFlag tv1 - ; b2 <- tvBindFlag tv2 - ; case (b1,b2) of - (BindMe, _) -> bind tv1 ty2 - (Skolem, Skolem) -> failWith (misMatch ty1 ty2) - (Skolem, _) -> bind tv2 ty1 - } - - | k1 `isSubKind` k2 = bindTv subst tv2 ty1 -- Must update tv2 - | k2 `isSubKind` k1 = bindTv subst tv1 ty2 -- Must update tv1 - - | otherwise = failWith (kindMisMatch tv1 ty2) - where - ty1 = TyVarTy tv1 - k1 = tyVarKind tv1 - k2 = tyVarKind tv2 - bind tv ty = return $ extendVarEnv subst tv ty + = case (k1_sub_k2, k2_sub_k1) of + (True, True) -> choose subst + (True, False) -> bindTv subst tv2 ty1 + (False, True) -> bindTv subst tv1 ty2 + (False, False) -> do + { subst' <- unify subst k1 k2 + ; choose subst' } + where subst_kind = mkTvSubst (mkInScopeSet (tyVarsOfTypes [k1,k2])) subst + k1 = substTy subst_kind (tyVarKind tv1) + k2 = substTy subst_kind (tyVarKind tv2) + k1_sub_k2 = k1 `isSubKind` k2 + k2_sub_k1 = k2 `isSubKind` k1 + ty1 = TyVarTy tv1 + bind subst tv ty = return $ extendVarEnv subst tv ty + choose subst = do + { b1 <- tvBindFlag tv1 + ; b2 <- tvBindFlag tv2 + ; case (b1, b2) of + (BindMe, _) -> bind subst tv1 ty2 + (Skolem, Skolem) -> failWith (misMatch ty1 ty2) + (Skolem, _) -> bind subst tv2 ty1 } uUnrefined subst tv1 ty2 ty2' -- ty2 is not a type variable | tv1 `elemVarSet` niSubstTvSet subst (tyVarsOfType ty2') diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index d69e8ada63..60fbe5b29a 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -30,7 +30,7 @@ module Outputable ( char, text, ftext, ptext, int, integer, float, double, rational, - parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets, + parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, semi, comma, colon, dcolon, space, equals, dot, arrow, darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, blankLine, @@ -449,11 +449,12 @@ float n = docToSDoc $ Pretty.float n double n = docToSDoc $ Pretty.double n rational n = docToSDoc $ Pretty.rational n -parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc +parens, braces, brackets, quotes, quote, doubleQuotes, angleBrackets :: SDoc -> SDoc parens d = SDoc $ Pretty.parens . runSDoc d braces d = SDoc $ Pretty.braces . runSDoc d brackets d = SDoc $ Pretty.brackets . runSDoc d +quote d = SDoc $ Pretty.quote . runSDoc d doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d angleBrackets d = char '<' <> d <> char '>' diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index 0493daabee..cc8f235f2c 100644 --- a/compiler/utils/Pretty.lhs +++ b/compiler/utils/Pretty.lhs @@ -106,7 +106,7 @@ Relative to John's original paper, there are the following new features: These new ones do the obvious things: char, semi, comma, colon, space, parens, brackets, braces, - quotes, doubleQuotes + quotes, quote, doubleQuotes 4. The "above" combinator, $$, now overlaps its two arguments if the last line of the top argument stops before the first line of the second begins. @@ -165,7 +165,7 @@ module Pretty ( char, text, ftext, ptext, zeroWidthText, int, integer, float, double, rational, - parens, brackets, braces, quotes, doubleQuotes, + parens, brackets, braces, quotes, quote, doubleQuotes, semi, comma, colon, space, equals, lparen, rparen, lbrack, rbrack, lbrace, rbrace, cparen, @@ -233,8 +233,8 @@ char :: Char -> Doc semi, comma, colon, space, equals :: Doc lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc -parens, brackets, braces :: Doc -> Doc -quotes, doubleQuotes :: Doc -> Doc +parens, brackets, braces :: Doc -> Doc +quotes, quote, doubleQuotes :: Doc -> Doc int :: Int -> Doc integer :: Integer -> Doc @@ -409,6 +409,7 @@ rational n = text (show (fromRat n :: Double)) --rational n = text (show (fromRationalX n)) -- _showRational 30 n) quotes p = char '`' <> p <> char '\'' +quote p = char '\'' <> p doubleQuotes p = char '"' <> p <> char '"' parens p = char '(' <> p <> char ')' brackets p = char '[' <> p <> char ']' diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index a7d984cf83..bd531867de 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -54,7 +54,7 @@ initV :: HscEnv -> IO (Maybe (VectInfo, a)) initV hsc_env guts info thing_inside = do { - let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_clss guts) (mg_fam_insts guts) + let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) ; (_, Just res) <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) type_env go |