[commit: ghc] overlapping-tyfams: A few bugfixes. (d0d1120)

[Richard Eisenberg]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : overlapping-tyfams

https://github.com/ghc/ghc/commit/d0d112063faffd884bd566a70a057c505c998644

>---------------------------------------------------------------

commit d0d112063faffd884bd566a70a057c505c998644
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Wed Jun 19 10:30:07 2013 +0100

    A few bugfixes.

>---------------------------------------------------------------

 compiler/typecheck/TcTyClsDecls.lhs | 25 ++++++++++++++++++-------
 compiler/typecheck/TcValidity.lhs   | 10 ++++++++--
 2 files changed, 26 insertions(+), 9 deletions(-)

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 4d334ef..badfef4 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -903,12 +903,18 @@ tcFamTyPats :: Name -- of the family TyCon
 tcFamTyPats fam_tc_name kind
             (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars })
             kind_checker thing_inside
-  = do { -- 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_kvs, fam_body) = splitForAllTys kind
+  = do { let (fam_kvs, fam_body) = splitForAllTys kind
+
+         -- We wish to check that the pattern has the right number of arguments
+         -- in checkValidFamPats (in TcValidity), so we can do the check *after*
+         -- we're done with the knot. But, the splitKindFunTysN below will panic
+         -- if there are *too many* patterns. So, we do a preliminary check here.
+         -- Note that we don't have enough information at hand to do a full check,
+         -- as that requires the full declared arity of the family, which isn't
+         -- nearby.
+       ; let max_args = length (fst $ splitKindFunTys kind)
+       ; checkTc (length arg_pats <= max_args) $
+           wrongNumberOfParmsErrTooMany max_args
 
          -- Instantiate with meta kind vars
        ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs
@@ -1780,7 +1786,7 @@ tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a
 tcAddClosedTypeFamilyDeclCtxt tc
   = addErrCtxt ctxt
   where
-    ctxt = ptext (sLit "In the declaration for closed type family") <+>
+    ctxt = ptext (sLit "In the equations for closed type family") <+>
            quotes (ppr tc)
 
 resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
@@ -1899,6 +1905,11 @@ wrongKindOfFamily family
                  | isAlgTyCon family = ptext (sLit "data type")
                  | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
 
+wrongNumberOfParmsErrTooMany :: Arity -> SDoc
+wrongNumberOfParmsErrTooMany max_args
+  = ptext (sLit "Number of parameters must match family declaration; expected no more than")
+    <+> ppr max_args
+
 wrongNamesInInstGroup :: Name -> Name -> SDoc
 wrongNamesInInstGroup first cur
   = ptext (sLit "Mismatched type names in closed type family declaration.") $$
diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs
index 192de1e..5846e28 100644
--- a/compiler/typecheck/TcValidity.lhs
+++ b/compiler/typecheck/TcValidity.lhs
@@ -1136,12 +1136,18 @@ checkValidFamPats :: TyCon -> [TyVar] -> [Type] -> TcM ()
 --         type instance F (T a) = a
 -- c) Have the right number of patterns
 checkValidFamPats fam_tc tvs ty_pats
-  = do { checkTc (length ty_pats == fam_arity) $
-           wrongNumberOfParmsErr fam_arity
+  = do { -- 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)
+         checkTc (length ty_pats == fam_arity) $
+           wrongNumberOfParmsErr (fam_arity - length fam_kvs) -- report only types
        ; mapM_ checkTyFamFreeness ty_pats
        ; let unbound_tvs = filterOut (`elemVarSet` exactTyVarsOfTypes ty_pats) tvs
        ; checkTc (null unbound_tvs) (famPatErr fam_tc unbound_tvs ty_pats) }
   where fam_arity    = tyConArity fam_tc
+        (fam_kvs, _) = splitForAllTys (tyConKind fam_tc)
 
 wrongNumberOfParmsErr :: Arity -> SDoc
 wrongNumberOfParmsErr exp_arity