X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=56ff0e1bca581364956792b3b1b5cb60da3256cd;hb=485c8034041b7d7f26688c24b88a50a62e3d3229;hp=ae90ef8f4ed5b26be6b043454db673c733f40880;hpb=b0e7c6f2d78e856761944c27755b442e36ead60f;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index ae90ef8..56ff0e1 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -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,11 @@ 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 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)) @@ -314,7 +318,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? @@ -339,7 +343,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) @@ -568,7 +572,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) 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 @@ -657,10 +662,11 @@ tcTyClDecl1 calc_isrec ; 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) @@ -775,8 +781,8 @@ tcConDecl unbox_strict tycon tc_tvs -- Data types 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 @@ -1008,6 +1014,9 @@ checkNewDataCon con -- Return type is (T a b c) ; checkTc (null ex_tvs && null 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 @@ -1139,7 +1148,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 -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) @@ -1152,6 +1161,10 @@ newtypeExError con = sep [ptext SLIT("A newtype constructor cannot have an existential context,"), nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")] +newtypeStrictError con + = sep [ptext SLIT("A newtype constructor cannot have a strictness annotation,"), + nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does")] + newtypePredError con = sep [ptext SLIT("A newtype constructor must have a return type of form T a1 ... an"), nest 2 $ ptext SLIT("but") <+> quotes (ppr con) <+> ptext SLIT("does not")] @@ -1168,7 +1181,7 @@ badSigTyDecl 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") <+> @@ -1194,6 +1207,10 @@ 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 + emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")]