import BasicTypes
import HscTypes
import BuildTyCl
+import TcUnify
import TcRnMonad
import TcEnv
import TcTyDecls
tcAddDeclCtxt decl $
do { -- type families require -ftype-families 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
; -- (1) kind check the right-hand side of the type equation
; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
+ -- we need at least as many type parameters as the family declaration
+ -- specified
+ ; let famArity = tyConArity family
+ ; checkTc (length k_typats >= famArity) $ tooFewParmsErr 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
+ -- all parameters in excess of the family arity must be variables
+ ; checkTc (all isTyVarTy $ drop famArity t_typats) $ excessParmVarErr
+
-- (3) check that
-- - left-hand side contains no type family applications
-- (vanilla synonyms are fine, though)
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
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
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) }
-- 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}
; stupid_theta <- tcHsKindedContext ctxt
; want_generic <- doptM Opt_Generics
; unbox_strict <- doptM Opt_UnboxStrictFields
- ; gla_exts <- doptM Opt_GlasgowExts
; empty_data_decls <- doptM Opt_EmptyDataDecls
; kind_signatures <- doptM Opt_KindSignatures
; gadt_ok <- doptM Opt_GADTs
-------------------------------
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
; 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
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
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!
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)
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") <+>
= 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
+
+excessParmVarErr
+ = ptext SLIT("Additional instance parameters must be variables")
badBootFamInstDeclErr =
ptext SLIT("Illegal family instance in hs-boot file")