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/typecheck/TcHsType.lhs | |
| 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/typecheck/TcHsType.lhs')
| -rw-r--r-- | compiler/typecheck/TcHsType.lhs | 19 |
1 files changed, 14 insertions, 5 deletions
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 |