import Digraph
import DynFlags
-import Data.List ( partition, elemIndex )
+import Data.List
import Control.Monad ( mplus )
\end{code}
unless (isSynTyCon family) $
addErr (wrongKindOfFamily family)
- ; -- (1) kind check the right hand side of the type equation
+ ; -- (1) kind check the right-hand side of the type equation
; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind
-- (2) type check type equation
; t_typats <- mappM tcHsKindedType k_typats
; t_rhs <- tcHsKindedType k_rhs
- -- (3) construct representation tycon
+ -- (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)
+
+ -- (4) construct representation tycon
; rep_tc_name <- newFamInstTyConName tc_name loc
; tycon <- buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
(Just (family, t_typats))
; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
; unbox_strict <- doptM Opt_UnboxStrictFields
- -- Check that we don't use GADT syntax for indexed types
+ -- kind check the type indexes and the context
+ ; t_typats <- mappM tcHsKindedType k_typats
+ ; stupid_theta <- tcHsKindedContext k_ctxt
+
+ -- (3) Check that
+ -- - left-hand side contains no type family applications
+ -- (vanilla synonyms are fine, though)
+ ; mappM_ checkTyFamFreeness t_typats
+
+ -- - we don't use GADT syntax for indexed types
; checkTc h98_syntax (badGadtIdxTyDecl tc_name)
- -- Check that a newtype has exactly one constructor
+ -- - a newtype has exactly one constructor
; checkTc (new_or_data == DataType || isSingleton k_cons) $
newtypeConError tc_name (length k_cons)
- ; t_typats <- mappM tcHsKindedType k_typats
- ; stupid_theta <- tcHsKindedContext k_ctxt
-
- -- (3) construct representation tycon
+ -- (4) construct representation tycon
; rep_tc_name <- newFamInstTyConName tc_name loc
; tycon <- fixM (\ tycon -> do
{ data_cons <- mappM (addLocM (tcConDecl unbox_strict tycon t_tvs))
case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
NewType -> ASSERT( isSingleton data_cons )
- mkNewTyConRhs tc_name tycon (head 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))
-- We always assume that indexed types are recursive. Why?
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
-- -
--
-- * Here we check that a type instance matches its kind signature, but we do
-- not check whether there is a pattern for each type index; the latter
--- check is only required for type functions.
+-- check is only required for type synonym instances.
--
kcIdxTyPats :: TyClDecl Name
-> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
kc_con_details (RecCon fields)
= do { fields' <- mappM kc_field fields; return (RecCon fields') }
- kc_field (HsRecField fld bty d) = do { bty' <- kc_larg_ty bty ; return (HsRecField fld bty' d) }
+ kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty
+ ; return (ConDeclField fld bty' d) }
kc_larg_ty bty = case new_or_data of
DataType -> kcHsSigType bty
; 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
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
-- Check that we don't use GADT syntax in H98 world
- ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name)
+ ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name)
-- Check that we don't use kind signatures without Glasgow extensions
- ; checkTc (gla_exts || isNothing mb_ksig) (badSigTyDecl tc_name)
+ ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
-- Check that the stupid theta is empty for a GADT-style declaration
; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
-- Check that there's at least one condecl,
- -- or else we're reading an hs-boot file, or -fglasgow-exts
- ; checkTc (not (null cons) || gla_exts || is_boot)
+ -- or else we're reading an hs-boot file, or -XEmptyDataDecls
+ ; checkTc (not (null cons) || empty_data_decls || is_boot)
(emptyConDeclsErr tc_name)
-- Check that a newtype has exactly one constructor
InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2]
RecCon fields -> tc_datacon False field_names btys
where
- (field_names, btys) = unzip [ (n, t) | HsRecField n t _ <- fields ]
-
+ field_names = map cd_fld_name fields
+ btys = map cd_fld_type fields
}
tcResultType :: TyCon
-- Return type is (T a b c)
; checkTc (null ex_tvs && null theta) (newtypeExError con)
-- No existentials
- ; checkTc (null (dataConStrictMarks con)) (newtypeStrictError con)
+ ; checkTc (not (any isMarkedStrict (dataConStrictMarks con)))
+ (newtypeStrictError con)
-- No strictness
}
where
checkValidClass cls
= do { -- CHECK ARITY 1 FOR HASKELL 1.4
gla_exts <- doptM Opt_GlasgowExts
+ ; multi_param_type_classes <- doptM Opt_MultiParamTypeClasses
+ ; fundep_classes <- doptM Opt_FunctionalDependencies
-- Check that the class is unary, unless GlaExs
; checkTc (notNull tyvars) (nullaryClassErr cls)
- ; checkTc (gla_exts || unary) (classArityErr cls)
+ ; checkTc (multi_param_type_classes || unary) (classArityErr cls)
+ ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
-- Check the super-classes
; checkValidTheta (ClassSCCtxt (className cls)) theta
; checkTc (unary || no_generics) (genericMultiParamErr cls)
}
where
- (tyvars, theta, _, op_stuff) = classBigSig cls
+ (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
unary = isSingleton tyvars
no_generics = null [() | (_, GenDefMeth) <- op_stuff]
classArityErr cls
= vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
- parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]
+ parens (ptext SLIT("Use -XMultiParamTypeClasses to allow multi-parameter classes"))]
+
+classFunDepsErr cls
+ = vcat [ptext SLIT("Fundeps in class") <+> quotes (ppr cls),
+ parens (ptext SLIT("Use -XFunctionalDependencies to allow fundeps"))]
noClassTyVarErr clas op
= sep [ptext SLIT("The class method") <+> quotes (ppr op),
badGadtDecl tc_name
= vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name)
- , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ]
+ , nest 2 (parens $ ptext SLIT("Use -X=GADT to allow GADTs")) ]
badStupidTheta tc_name
= ptext SLIT("A data type declared in GADT style cannot have a context:") <+> quotes (ppr tc_name)
badSigTyDecl tc_name
= vcat [ ptext SLIT("Illegal kind signature") <+>
quotes (ppr tc_name)
- , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow kind signatures")) ]
+ , nest 2 (parens $ ptext SLIT("Use -XKindSignatures to allow kind signatures")) ]
badFamInstDecl tc_name
= vcat [ ptext SLIT("Illegal family instance for") <+>
quotes (ppr tc_name)
- , nest 2 (parens $ ptext SLIT("Use -ftype-families to allow indexed type families")) ]
+ , nest 2 (parens $ ptext SLIT("Use -X=TypeFamilies to allow indexed type families")) ]
badGadtIdxTyDecl tc_name
= vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+>
| 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("(-fglasgow-exts permits this)")]
+ nest 2 $ ptext SLIT("(-XEmptyDataDecls permits this)")]
\end{code}