Type checking for type synonym families

[ghc-hetmet.git] / compiler / typecheck / TcTyClsDecls.lhs

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 8af4e85..863cd6d 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -263,6 +263,12 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
        ; -- (1) kind check the right-hand side of the type equation
        ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
 
+         -- we need the exact same number of type parameters as the family
+         -- declaration 
+       ; let famArity = tyConArity family
+       ; checkTc (length k_typats == famArity) $ 
+           wrongNumberOfParmsErr famArity
+
          -- (2) type check type equation
        ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
        ; t_typats <- mappM tcHsKindedType k_typats
@@ -299,7 +305,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
             k_cons = tcdCons k_decl
 
          -- result kind must be '*' (otherwise, we have too few patterns)
-       ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr tc_name
+       ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity family)
 
          -- (2) type check indexed data type declaration
        ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
@@ -329,7 +335,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
             ; tc_rhs <-
                 case new_or_data of
                   DataType -> return (mkDataTyConRhs data_cons)
-                  NewType  -> ASSERT( isSingleton data_cons )
+                  NewType  -> ASSERT( not (null data_cons) )
                               mkNewTyConRhs rep_tc_name tycon (head data_cons)
             ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
                             False h98_syntax (Just (family, t_typats))
@@ -746,7 +752,7 @@ tcTyClDecl1 calc_isrec
            else case new_or_data of
                   DataType -> return (mkDataTyConRhs data_cons)
                   NewType  -> 
-                       ASSERT( isSingleton data_cons )
+                       ASSERT( not (null data_cons) )
                        mkNewTyConRhs tc_name tycon (head data_cons)
        ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
            (want_generic && canDoGenerics data_cons) h98_syntax Nothing
@@ -1066,14 +1072,14 @@ checkNewDataCon con
                -- One argument
        ; checkTc (null eq_spec) (newtypePredError con)
                -- Return type is (T a b c)
-       ; checkTc (null ex_tvs && null theta) (newtypeExError con)
+       ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con)
                -- No existentials
        ; checkTc (not (any isMarkedStrict (dataConStrictMarks con))) 
                  (newtypeStrictError con)
                -- No strictness
     }
   where
-    (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con
+    (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con
 
 -------------------------------
 checkValidClass :: Class -> TcM ()
@@ -1109,6 +1115,7 @@ checkValidClass cls
                -- The 'tail' removes the initial (C a) from the
                -- class itself, leaving just the method type
 
+       ; traceTc (text "class op type" <+> ppr op_ty <+> ppr tau)
        ; checkValidType (FunSigCtxt op_name) tau
 
                -- Check that the type mentions at least one of
@@ -1252,9 +1259,13 @@ tooManyParmsErr tc_name
   = ptext SLIT("Family instance has too many parameters:") <+> 
     quotes (ppr tc_name)
 
-tooFewParmsErr tc_name
-  = ptext SLIT("Family instance has too few parameters:") <+> 
-    quotes (ppr tc_name)
+tooFewParmsErr arity
+  = ptext SLIT("Family instance has too few parameters; expected") <+> 
+    ppr arity
+
+wrongNumberOfParmsErr exp_arity
+  = ptext SLIT("Number of parameters must match family declaration; expected")
+    <+> ppr exp_arity
 
 badBootFamInstDeclErr = 
   ptext SLIT("Illegal family instance in hs-boot file")