X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=9c4b5b20d8ae954beacb17906e5e734d48cb27e1;hb=f4e4060721bdbeee81d5e9fd3c8d909ece6195df;hp=49425a4706f0fb17cf55605fdb9349858a8c4c52;hpb=2eb04ca0f8d0ec72b417cddc60672c696b4a3daa;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 49425a4..9c4b5b2 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -44,7 +44,7 @@ import ListSetOps import Digraph import DynFlags -import Data.List ( partition, elemIndex ) +import Data.List import Control.Monad ( mplus ) \end{code} @@ -259,7 +259,7 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) 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 @@ -267,7 +267,16 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) ; 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)) @@ -295,17 +304,23 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; 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)) @@ -314,7 +329,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, 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? @@ -332,6 +347,27 @@ 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 -- - @@ -339,7 +375,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, -- -- * 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) @@ -658,6 +694,7 @@ tcTyClDecl1 calc_isrec ; want_generic <- doptM Opt_Generics ; unbox_strict <- doptM Opt_UnboxStrictFields ; gla_exts <- doptM Opt_GlasgowExts + ; empty_data_decls <- doptM Opt_EmptyDataDecls ; gadt_ok <- doptM Opt_GADTs ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? @@ -671,8 +708,8 @@ tcTyClDecl1 calc_isrec ; 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 @@ -1203,7 +1240,16 @@ 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("(-fglasgow-exts permits this)")] + nest 2 $ ptext SLIT("(-XEmptyDataDecls permits this)")] \end{code}