X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=60aa9d48272a18a2db48f0e9d75a490fe97f29c5;hb=744c2b73ba07e64762b01577a25ed8b0b46478b6;hp=9e302c3a6168517439296fa036d235ce9b6df19a;hpb=fcb83d8469d4d7f282754387369aa86d40429dcf;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 9e302c3..60aa9d4 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -6,6 +6,13 @@ TcTyClsDecls: Typecheck type and class declarations \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcTyClsDecls ( tcTyAndClassDecls, tcFamInstDecl ) where @@ -17,6 +24,7 @@ import HsTypes import BasicTypes import HscTypes import BuildTyCl +import TcUnify import TcRnMonad import TcEnv import TcTyDecls @@ -239,11 +247,11 @@ tcFamInstDecl (L loc decl) recoverM (returnM Nothing) $ setSrcSpan loc $ tcAddDeclCtxt decl $ - do { -- type families require -ftype-families and can't be in an + do { -- type families require -XTypeFamilies and can't be in an -- hs-boot file - ; gla_exts <- doptM Opt_TypeFamilies + ; type_families <- doptM Opt_TypeFamilies ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; checkTc gla_exts $ badFamInstDecl (tcdLName decl) + ; checkTc type_families $ badFamInstDecl (tcdLName decl) ; checkTc (not is_boot) $ badBootFamInstDeclErr -- perform kind and type checking @@ -262,19 +270,20 @@ 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 ; t_rhs <- tcHsKindedType k_rhs -- (3) check that - -- - left-hand side contains no type family applications - -- (vanilla synonyms are fine, though) - ; mappM_ checkTyFamFreeness t_typats - - -- - the right-hand side is a tau type - ; unless (isTauTy t_rhs) $ - addErr (polyTyErr t_rhs) + -- - check the well-formedness of the instance + ; checkValidTypeInst t_typats t_rhs -- (4) construct representation tycon ; rep_tc_name <- newFamInstTyConName tc_name loc @@ -298,7 +307,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 @@ -310,7 +319,8 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, -- (3) Check that -- - left-hand side contains no type family applications - -- (vanilla synonyms are fine, though) + -- (vanilla synonyms are fine, though, and we checked for + -- foralls earlier) ; mappM_ checkTyFamFreeness t_typats -- - we don't use GADT syntax for indexed types @@ -328,7 +338,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)) @@ -347,27 +357,6 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False other -> True --- Check that a type index does not contain any type family applications --- --- * Earlier phases have already checked that there are no foralls in the --- type; we also cannot have PredTys and NoteTys are being skipped by using --- the core view. --- -checkTyFamFreeness :: Type -> TcM () -checkTyFamFreeness ty | Just (tycon, tys) <- splitTyConApp_maybe ty - = if isSynTyCon tycon - then addErr $ tyFamAppInIndexErr ty - else mappM_ checkTyFamFreeness tys - -- splitTyConApp_maybe uses the core view; hence, - -- any synonym tycon must be a family tycon - - | Just (ty1, ty2) <- splitAppTy_maybe ty - = checkTyFamFreeness ty1 >> checkTyFamFreeness ty2 - - | otherwise -- only vars remaining - = return () - - -- Kind checking of indexed types -- - @@ -535,18 +524,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 +584,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 +603,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} @@ -657,14 +666,14 @@ tcTyClDecl1 _calc_isrec { traceTc (text "type family: " <+> ppr tc_name) ; idx_tys <- doptM Opt_TypeFamilies - -- Check that we don't use families without -ftype-families + -- Check that we don't use families without -XTypeFamilies ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) Nothing ; return [ATyCon tycon] } - -- "newtype family" or "data family" declaration + -- "data family" declaration tcTyClDecl1 _calc_isrec (TyFamily {tcdFlavour = DataFamily, tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind}) @@ -675,7 +684,7 @@ tcTyClDecl1 _calc_isrec ; idx_tys <- doptM Opt_TypeFamilies - -- Check that we don't use families without -ftype-families + -- Check that we don't use families without -XTypeFamilies ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildAlgTyCon tc_name final_tvs [] @@ -684,6 +693,7 @@ tcTyClDecl1 _calc_isrec } -- "newtype" and "data" + -- NB: not used for newtype/data instances (whether associated or not) tcTyClDecl1 calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) @@ -725,7 +735,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 @@ -746,6 +756,8 @@ tcTyClDecl1 calc_isrec { ctxt' <- tcHsKindedContext ctxt ; fds' <- mappM (addLocM tc_fundep) fundeps ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats + -- NB: 'ats' only contains "type family" and "data family" + -- declarations as well as type family defaults ; let ats' = zipWith setTyThingPoss atss (map (tcdTyVars . unLoc) ats) ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> @@ -1045,20 +1057,19 @@ 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 () checkValidClass cls - = do { -- CHECK ARITY 1 FOR HASKELL 1.4 - gla_exts <- doptM Opt_GlasgowExts + = do { constrained_class_methods <- doptM Opt_ConstrainedClassMethods ; multi_param_type_classes <- doptM Opt_MultiParamTypeClasses ; fundep_classes <- doptM Opt_FunctionalDependencies @@ -1071,7 +1082,7 @@ checkValidClass cls ; checkValidTheta (ClassSCCtxt (className cls)) theta -- Check the class operations - ; mappM_ (check_op gla_exts) op_stuff + ; mappM_ (check_op constrained_class_methods) op_stuff -- Check that if the class has generic methods, then the -- class has only one parameter. We can't do generic @@ -1083,12 +1094,13 @@ checkValidClass cls unary = isSingleton tyvars no_generics = null [() | (_, GenDefMeth) <- op_stuff] - check_op gla_exts (sel_id, dm) + check_op constrained_class_methods (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do { checkValidTheta SigmaCtxt (tail theta) -- 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 @@ -1111,11 +1123,11 @@ checkValidClass cls op_ty = idType sel_id (_,theta1,tau1) = tcSplitSigmaTy op_ty (_,theta2,tau2) = tcSplitSigmaTy tau1 - (theta,tau) | gla_exts = (theta1 ++ theta2, tau2) - | otherwise = (theta1, mkPhiTy (tail theta1) tau1) + (theta,tau) | constrained_class_methods = (theta1 ++ theta2, tau2) + | otherwise = (theta1, mkPhiTy (tail theta1) tau1) -- Ugh! The function might have a type like -- op :: forall a. C a => forall b. (Eq b, Eq a) => tau2 - -- With -fglasgow-exts, we want to allow this, even though the inner + -- With -XConstrainedClassMethods, we want to allow this, even though the inner -- forall has an (Eq a) constraint. Whereas in general, each constraint -- in the context of a for-all must mention at least one quantified -- type variable. What a mess! @@ -1188,7 +1200,7 @@ badDataConTyCon data_con badGadtDecl tc_name = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -X=GADT to allow GADTs")) ] + , nest 2 (parens $ ptext SLIT("Use -XGADTs to allow GADTs")) ] badStupidTheta tc_name = ptext SLIT("A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name) @@ -1221,7 +1233,7 @@ badSigTyDecl tc_name badFamInstDecl tc_name = vcat [ ptext SLIT("Illegal family instance for") <+> quotes (ppr tc_name) - , nest 2 (parens $ ptext SLIT("Use -X=TypeFamilies to allow indexed type families")) ] + , nest 2 (parens $ ptext SLIT("Use -XTypeFamilies to allow indexed type families")) ] badGadtIdxTyDecl tc_name = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> @@ -1232,9 +1244,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") @@ -1247,15 +1263,6 @@ wrongKindOfFamily family = | isAlgTyCon family = ptext SLIT("data type") | otherwise = pprPanic "wrongKindOfFamily" (ppr family) -polyTyErr ty - = hang (ptext SLIT("Illegal polymorphic type in type instance") <> colon) 4 $ - ppr ty - -tyFamAppInIndexErr ty - = hang (ptext SLIT("Illegal type family application in type instance") <> - colon) 4 $ - ppr ty - emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), nest 2 $ ptext SLIT("(-XEmptyDataDecls permits this)")]