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
; want_generic <- doptM Opt_Generics
; unbox_strict <- doptM Opt_UnboxStrictFields
; gla_exts <- doptM Opt_GlasgowExts
+ ; 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)
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
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)
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)")]