X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyDecls.lhs;h=0e83986ca8bfc9f8e1a46304fe1963f976e0e407;hb=2c8f04b5b883db74f449dfc8c224929fe28b027d;hp=11482dddf06086eae1844380c0b657af450fe172;hpb=aa6ac88a396159d7bde2e95d2d09ad24b90d45d8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 11482dd..0e83986 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -4,83 +4,75 @@ \section[TcTyDecls]{Typecheck type declarations} \begin{code} -#include "HsVersions.h" - module TcTyDecls ( tcTyDecl, tcConDecl, mkDataBinds ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import HsSyn ( TyDecl(..), ConDecl(..), ConDetails(..), BangType(..), HsExpr(..), - Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), - HsBinds(..), HsLit, Stmt, DoOrListComp, ArithSeqInfo, - SYN_IE(RecFlag), nonRecursive, - HsType, Fake, InPat, HsTyVar, Fixity, - MonoBinds(..), Sig +import HsSyn ( MonoBinds(..), + TyDecl(..), ConDecl(..), ConDetails(..), BangType(..), + andMonoBinds ) import HsTypes ( getTyVarName ) import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) ) import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType, - SYN_IE(TcHsBinds), TcIdOcc(..) + TcHsBinds, TcMonoBinds ) +import BasicTypes ( RecFlag(..), NewOrData(..) ) + import Inst ( newDicts, InstOrigin(..), Inst ) import TcMonoType ( tcHsTypeKind, tcHsType, tcContext ) -import TcSimplify ( tcSimplifyThetas ) -import TcType ( tcInstTyVars, tcInstType, tcInstId ) -import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass, +import TcSimplify ( tcSimplifyCheckThetas ) +import TcType ( tcInstTyVars ) +import TcEnv ( TcIdOcc(..), tcInstId, + tcLookupTyCon, tcLookupTyVar, tcLookupClass, newLocalId, newLocalIds, tcLookupClassByKey ) import TcMonad -import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind ) +import TcKind ( TcKind, unifyKind, mkArrowKind, mkBoxedTypeKind ) -import PprType ( GenClass, GenType{-instance Outputable-}, - GenTyVar{-instance Outputable-}{-ToDo:possibly rm-} - ) -import CoreUnfold ( getUnfoldingTemplate ) -import Class ( GenClass{-instance Eq-}, classInstEnv, SYN_IE(Class) ) -import Id ( mkDataCon, dataConSig, mkRecordSelId, idType, +import Class ( classInstEnv, Class ) +import MkId ( mkDataCon, mkRecordSelId ) +import Id ( dataConSig, idType, dataConFieldLabels, dataConStrictMarks, StrictnessMark(..), getIdUnfolding, - GenId{-instance NamedThing-}, - SYN_IE(Id) + Id ) +import CoreUnfold ( getUnfoldingTemplate ) import FieldLabel import Kind ( Kind, mkArrowKind, mkBoxedTypeKind ) -import SpecEnv ( SpecEnv, nullSpecEnv ) import Name ( nameSrcLoc, isLocallyDefined, getSrcLoc, - OccName(..), Name{-instance Ord3-}, + OccName(..), NamedThing(..) ) -import Outputable ( Outputable(..), interpp'SP ) -import Pretty -import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, isDataTyCon, - isNewTyCon, isSynTyCon, tyConDataCons +import Outputable +import TyCon ( TyCon, mkSynTyCon, mkDataTyCon, isAlgTyCon, + isSynTyCon, tyConDataCons ) -import Type ( GenType, -- instances - typeKind, getTyVar, tyVarsOfTypes, eqTy, splitSigmaTy, - applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy, - splitFunTy, mkTyVarTy, getTyVar_maybe, - SYN_IE(Type) +import Type ( typeKind, getTyVar, tyVarsOfTypes, splitSigmaTy, + mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy, + splitFunTys, mkTyVarTy, getTyVar_maybe, + isUnboxedType, Type, ThetaType ) -import TyVar ( tyVarKind, elementOfTyVarSet, - GenTyVar{-instance Eq-}, SYN_IE(TyVar) ) -import Unique ( Unique {- instance Eq -}, evalClassKey ) -import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, SYN_IE(UniqSet) ) -import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic, Ord3(..) ) +import TyVar ( tyVarKind, elementOfTyVarSet, intersectTyVarSets, isEmptyTyVarSet, + TyVar ) +import Unique ( evalClassKey ) +import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet ) +import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic ) \end{code} \begin{code} -tcTyDecl :: RenamedTyDecl -> TcM s TyCon +tcTyDecl :: RecFlag -> RenamedTyDecl -> TcM s TyCon \end{code} Type synonym decls ~~~~~~~~~~~~~~~~~~ \begin{code} -tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc) +tcTyDecl is_rec (TySynonym tycon_name tyvar_names rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (tySynCtxt tycon_name) $ @@ -94,7 +86,7 @@ tcTyDecl (TySynonym tycon_name tyvar_names rhs src_loc) -- Unify tycon kind with (k1->...->kn->rhs) unifyKind tycon_kind - (foldr mkTcArrowKind rhs_kind tyvar_kinds) + (foldr mkArrowKind rhs_kind tyvar_kinds) `thenTc_` let -- Getting the TyCon's kind is a bit of a nuisance. We can't use the tycon_kind, @@ -120,9 +112,13 @@ Algebraic data and newtype decls ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcTyDecl (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc) +tcTyDecl is_rec (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc) = tcAddSrcLoc src_loc $ - tcAddErrCtxt (tyDataCtxt tycon_name) $ + let ctxt = case data_or_new of + NewType -> tyNewCtxt tycon_name + DataType -> tyDataCtxt tycon_name + in + tcAddErrCtxt ctxt $ -- Lookup the pieces tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) -> @@ -135,7 +131,7 @@ tcTyDecl (TyData data_or_new context tycon_name tyvar_names con_decls derivings -- Unify tycon kind with (k1->...->kn->Type) unifyKind tycon_kind - (foldr mkTcArrowKind mkTcTypeKind tyvar_kinds) + (foldr mkArrowKind mkBoxedTypeKind tyvar_kinds) `thenTc_` -- Walk the condecls @@ -152,7 +148,9 @@ tcTyDecl (TyData data_or_new context tycon_name tyvar_names con_decls derivings ctxt con_ids derived_classes + Nothing -- Not a dictionary data_or_new + is_rec in returnTc tycon @@ -168,16 +166,16 @@ Generating constructor/selector bindings for data declarations ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -mkDataBinds :: [TyCon] -> TcM s ([Id], TcHsBinds s) -mkDataBinds [] = returnTc ([], EmptyBinds) +mkDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds s) +mkDataBinds [] = returnTc ([], EmptyMonoBinds) mkDataBinds (tycon : tycons) | isSynTyCon tycon = mkDataBinds tycons | otherwise = mkDataBinds_one tycon `thenTc` \ (ids1, b1) -> mkDataBinds tycons `thenTc` \ (ids2, b2) -> - returnTc (ids1++ids2, b1 `ThenBinds` b2) + returnTc (ids1++ids2, b1 `AndMonoBinds` b2) mkDataBinds_one tycon - = ASSERT( isDataTyCon tycon || isNewTyCon tycon ) + = ASSERT( isAlgTyCon tycon ) mapTc checkConstructorContext data_cons `thenTc_` mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids -> let @@ -189,9 +187,7 @@ mkDataBinds_one tycon | data_id <- data_ids, isLocallyDefined data_id ] in - returnTc (data_ids, - MonoBind (foldr AndMonoBinds EmptyMonoBinds binds) [] nonRecursive - ) + returnTc (data_ids, andMonoBinds binds) where data_cons = tyConDataCons tycon fields = [ (con, field) | con <- data_cons, @@ -201,7 +197,7 @@ mkDataBinds_one tycon -- groups is list of fields that share a common name groups = equivClasses cmp_name fields cmp_name (_, field1) (_, field2) - = fieldLabelName field1 `cmp` fieldLabelName field2 + = fieldLabelName field1 `compare` fieldLabelName field2 \end{code} -- Check that all the types of all the strict arguments are in Eval @@ -214,18 +210,16 @@ checkConstructorContext con_id | otherwise -- It is locally defined = tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas -> let - strict_marks = dataConStrictMarks con_id - (tyvars,theta,tau) = splitSigmaTy (idType con_id) - (arg_tys, result_ty) = splitFunTy tau + strict_marks = dataConStrictMarks con_id + (tyvars, theta, ext_tyvars, ext_theta, arg_tys, _) = dataConSig con_id - eval_theta = [ (eval_clas,arg_ty) + eval_theta = [ (eval_clas, [arg_ty]) | (arg_ty, MarkedStrict) <- zipEqual "strict_args" - arg_tys strict_marks + arg_tys strict_marks ] in - tcSimplifyThetas classInstEnv theta eval_theta `thenTc` \ eval_theta' -> - checkTc (null eval_theta') - (missingEvalErr con_id eval_theta') + tcAddErrCtxt (evalCtxt con_id eval_theta) $ + tcSimplifyCheckThetas theta eval_theta \end{code} \begin{code} @@ -235,7 +229,7 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) -- Check that all the fields in the group have the same type -- This check assumes that all the constructors of a given -- data type use the same type variables - = checkTc (all (eqTy field_ty) other_tys) + = checkTc (all (== field_ty) other_tys) (fieldTypeMisMatch field_name) `thenTc_` returnTc selector_id where @@ -243,7 +237,7 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) field_name = fieldLabelName first_field_label other_tys = [fieldLabelType fl | (_, fl) <- other_fields] (tyvars, _, _, _, _, _) = dataConSig first_con - data_ty = applyTyCon tycon (mkTyVarTys tyvars) + data_ty = mkTyConApp tycon (mkTyVarTys tyvars) -- tyvars of first_con may be free in field_ty -- Now build the selector @@ -259,7 +253,7 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) Constructors ~~~~~~~~~~~~ \begin{code} -tcConDecl :: TyCon -> [TyVar] -> [(Class,Type)] -> RenamedConDecl -> TcM s Id +tcConDecl :: TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM s Id tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (VanillaCon btys) src_loc) = tcDataCon tycon tyvars ctxt name btys src_loc @@ -270,13 +264,16 @@ tcConDecl tycon tyvars ctxt (ConDecl op ex_ctxt (InfixCon bty1 bty2) src_loc) tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (NewCon ty) src_loc) = tcAddSrcLoc src_loc $ tcHsType ty `thenTc` \ arg_ty -> + -- can't allow an unboxed type here, because we're effectively + -- going to remove the constructor while coercing it to a boxed type. + checkTc (not (isUnboxedType arg_ty)) (newTypeUnboxedField ty) `thenTc_` let data_con = mkDataCon (getName name) [NotMarkedStrict] [{- No labelled fields -}] tyvars ctxt - [] [] -- Temporary + [] [] -- Temporary; existential chaps [arg_ty] tycon in @@ -298,7 +295,7 @@ tcConDecl tycon tyvars ctxt (ConDecl name ex_ctxt (RecCon fields) src_loc) field_labels tyvars (thinContext arg_tys ctxt) - [] [] -- Temporary + [] [] -- Temporary; existential chaps arg_tys tycon in @@ -321,7 +318,7 @@ tcDataCon tycon tyvars ctxt name btys src_loc [{- No field labels -}] tyvars (thinContext arg_tys ctxt) - [] [] -- Temporary + [] [] -- Temporary existential chaps arg_tys tycon in @@ -333,7 +330,8 @@ thinContext arg_tys ctxt = filter in_arg_tys ctxt where arg_tyvars = tyVarsOfTypes arg_tys - in_arg_tys (clas,ty) = getTyVar "tcDataCon" ty `elementOfTyVarSet` arg_tyvars + in_arg_tys (clas,tys) = not $ isEmptyTyVarSet $ + tyVarsOfTypes tys `intersectTyVarSets` arg_tyvars get_strictness (Banged _) = MarkedStrict get_strictness (Unbanged _) = NotMarkedStrict @@ -347,20 +345,24 @@ get_pty (Unbanged ty) = ty Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} -tySynCtxt tycon_name sty - = hsep [ptext SLIT("In the type declaration for"), ppr sty tycon_name] +tySynCtxt tycon_name + = hsep [ptext SLIT("In the type declaration for"), quotes (ppr tycon_name)] + +tyDataCtxt tycon_name + = hsep [ptext SLIT("In the data declaration for"), quotes (ppr tycon_name)] -tyDataCtxt tycon_name sty - = hsep [ptext SLIT("In the data declaration for"), ppr sty tycon_name] +tyNewCtxt tycon_name + = hsep [ptext SLIT("In the newtype declaration for"), quotes (ppr tycon_name)] -tyNewCtxt tycon_name sty - = hsep [ptext SLIT("In the newtype declaration for"), ppr sty tycon_name] +fieldTypeMisMatch field_name + = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)] -fieldTypeMisMatch field_name sty - = sep [ptext SLIT("Declared types differ for field"), ppr sty field_name] +newTypeUnboxedField ty + = sep [ptext SLIT("Newtype constructor field has an unboxed type:"), + quotes (ppr ty)] -missingEvalErr con eval_theta sty - = hsep [ptext SLIT("Missing Eval context for constructor"), - ppr sty con, - char ':', ppr sty eval_theta] +evalCtxt con eval_theta + = hsep [ptext SLIT("When checking the Eval context for constructor:"), + ppr con, + text "::", ppr eval_theta] \end{code}