; -- (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
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
; 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))
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
-- 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 ()
-- 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
= 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")