X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=863cd6df1fc06ee0302d876ef9fc03fa37817648;hb=df6d4b9ae4f9b5e167aec723b70aa20a448c01d6;hp=fc685a30c9300e11301d131315da19148337a871;hpb=589b4037655acdc7e1e6ba44861e5219c02f1334;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index fc685a3..863cd6d 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -17,6 +17,7 @@ import HsTypes import BasicTypes import HscTypes import BuildTyCl +import TcUnify import TcRnMonad import TcEnv import TcTyDecls @@ -262,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 @@ -298,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 @@ -328,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)) @@ -535,18 +542,15 @@ kcTyClDecl decl@(TyData {}) kcTyClDeclBody decl $ kcDataDecl decl -kcTyClDecl decl@(TyFamily {tcdKind = kind}) - = kcTyClDeclBody decl $ \ tvs' -> - return (decl {tcdTyVars = tvs', - tcdKind = kind `mplus` Just liftedTypeKind}) - -- default result kind is '*' +kcTyClDecl decl@(TyFamily {}) + = kcFamilyDecl [] decl -- the empty list signals a toplevel decl kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) = kcTyClDeclBody decl $ \ tvs' -> do { is_boot <- tcIsHsBoot ; ctxt' <- kcHsContext ctxt - ; ats' <- mappM (wrapLocM kcTyClDecl) ats - ; sigs' <- mappM (wrapLocM kc_sig ) sigs + ; ats' <- mappM (wrapLocM (kcFamilyDecl tvs')) ats + ; sigs' <- mappM (wrapLocM kc_sig) sigs ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs', tcdATs = ats'}) } where @@ -598,11 +602,15 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) kc_con_details (PrefixCon btys) - = do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') } + = do { btys' <- mappM kc_larg_ty btys + ; return (PrefixCon btys') } kc_con_details (InfixCon bty1 bty2) - = do { bty1' <- kc_larg_ty bty1; bty2' <- kc_larg_ty bty2; return (InfixCon bty1' bty2') } + = do { bty1' <- kc_larg_ty bty1 + ; bty2' <- kc_larg_ty bty2 + ; return (InfixCon bty1' bty2') } kc_con_details (RecCon fields) - = do { fields' <- mappM kc_field fields; return (RecCon fields') } + = do { fields' <- mappM kc_field fields + ; return (RecCon fields') } kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty ; return (ConDeclField fld bty' d) } @@ -613,6 +621,25 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) -- Can't allow an unlifted type for newtypes, because we're effectively -- going to remove the constructor while coercing it to a lifted type. -- And newtypes can't be bang'd + +-- Kind check a family declaration or type family default declaration. +-- +kcFamilyDecl :: [LHsTyVarBndr Name] -- tyvars of enclosing class decl if any + -> TyClDecl Name -> TcM (TyClDecl Name) +kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) + = kcTyClDeclBody decl $ \tvs' -> + do { mapM_ unifyClassParmKinds tvs' + ; return (decl {tcdTyVars = tvs', + tcdKind = kind `mplus` Just liftedTypeKind}) + -- default result kind is '*' + } + where + unifyClassParmKinds (L _ (KindedTyVar n k)) + | Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind + | otherwise = return () + classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs] +kcFamilyDecl _ decl@(TySynonym {}) -- type family defaults + = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet" \end{code} @@ -725,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 @@ -1045,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 () @@ -1088,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 @@ -1231,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")