diff options
| author | Richard Eisenberg <eir@cis.upenn.edu> | 2014-08-06 09:56:50 -0400 |
|---|---|---|
| committer | Richard Eisenberg <eir@cis.upenn.edu> | 2014-08-12 11:46:21 -0400 |
| commit | 64859308231551de2aed839003994b29b99409c0 (patch) | |
| tree | 8aaff1c91790d354bf2583fd89ea32fa573d57c0 /compiler | |
| parent | 8d27c764aca6dba9ec150cb7e4d68d03e8a7e338 (diff) | |
| download | haskell-64859308231551de2aed839003994b29b99409c0.tar.gz | |
Change definition of CUSK for data and class definitions (#9200).
Now, a CUSK is when (and only when) all type variables are annotated.
This allows classes to participate in polymorphic recursion.
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/hsSyn/HsTypes.lhs | 7 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsType.lhs | 19 |
2 files changed, 20 insertions, 6 deletions
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 08a0eef498..eada762738 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -25,7 +25,7 @@ module HsTypes ( ConDeclField(..), pprConDeclFields, - mkHsQTvs, hsQTvBndrs, + mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, @@ -188,6 +188,11 @@ data HsTyVarBndr name (LHsKind name) -- The user-supplied kind signature deriving (Data, Typeable) +-- | Does this 'HsTyVarBndr' come with an explicit kind annotation? +isHsKindedTyVar :: HsTyVarBndr name -> Bool +isHsKindedTyVar (UserTyVar {}) = False +isHsKindedTyVar (KindedTyVar {}) = True + data HsType name = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way -- the user wrote it originally, so that the printer can diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index cdeb191489..14a3c175f8 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -1068,10 +1068,15 @@ kcStrategy d@(ForeignType {}) = pprPanic "kcStrategy" (ppr d) kcStrategy (FamDecl fam_decl) = kcStrategyFamDecl fam_decl kcStrategy (SynDecl {}) = ParametricKinds -kcStrategy (DataDecl { tcdDataDefn = HsDataDefn { dd_kindSig = m_ksig }}) - | Just _ <- m_ksig = FullKindSignature - | otherwise = ParametricKinds -kcStrategy (ClassDecl {}) = ParametricKinds +kcStrategy decl@(DataDecl {}) = kcStrategyAlgDecl decl +kcStrategy decl@(ClassDecl {}) = kcStrategyAlgDecl decl + +kcStrategyAlgDecl :: TyClDecl Name -> KindCheckingStrategy +kcStrategyAlgDecl decl + | all (isHsKindedTyVar . unLoc) (hsQTvBndrs $ tcdTyVars decl) + = FullKindSignature + | otherwise + = ParametricKinds -- if the ClosedTypeFamily has no equations, do the defaulting to *, etc. kcStrategyFamDecl :: FamilyDecl Name -> KindCheckingStrategy @@ -1259,7 +1264,11 @@ kcTyClTyVars :: Name -> LHsTyVarBndrs Name -> TcM a -> TcM a kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside = kcScopedKindVars kvs $ do { tc_kind <- kcLookupKind name - ; let (arg_ks, _res_k) = splitKindFunTysN (length hs_tvs) tc_kind + ; let (_, mono_kind) = splitForAllTys tc_kind + -- if we have a FullKindSignature, the tc_kind may already + -- be generalized. The kvs get matched up while kind-checking + -- the types in kc_tv, below + (arg_ks, _res_k) = splitKindFunTysN (length hs_tvs) mono_kind -- There should be enough arrows, because -- getInitialKinds used the tcdTyVars ; name_ks <- zipWithM kc_tv hs_tvs arg_ks |