X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyDecls.lhs;h=b5973f722c3f7d7c850ceeea84ca3e61b045c8ea;hb=17879095049f5705c9734cab4f4c5d56f61f81a7;hp=3ad7b060b7318a0b58c30ae0350abb528ab25a14;hpb=68a1f0233996ed79824d11d946e9801473f6946c;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 3ad7b06..b5973f7 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -1,280 +1,286 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The AQUA Project, Glasgow University, 1996-1998 % -\section[TcTyDecls]{Typecheck algebraic datatypes and type synonyms} +\section[TcTyDecls]{Typecheck type declarations} \begin{code} +module TcTyDecls ( + tcTyDecl1, + kcConDetails, + mkImplicitDataBinds, mkNewTyConRep + ) where + #include "HsVersions.h" -module TcTyDecls ( tcTyDecls ) where +import HsSyn ( MonoBinds(..), + TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..), + getBangType + ) +import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext ) +import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) +import BasicTypes ( NewOrData(..) ) -import TcMonad -- typechecking monad machinery -import AbsSyn -- the stuff being typechecked +import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, tcHsTyVars, tcClassContext, + kcHsContext, kcHsSigType + ) +import TcEnv ( tcExtendTyVarEnv, + tcLookupTyCon, tcLookupClass, tcLookupGlobalId, + TyThing(..), TyThingDetails(..) + ) +import TcMonad -import AbsUniType ( applyTyCon, mkDataTyCon, mkSynonymTyCon, - getUniDataTyCon, isUnboxedDataType, - isTyVarTemplateTy, cmpUniTypeMaybeList, - pprMaybeTy +import Class ( ClassContext ) +import DataCon ( DataCon, mkDataCon, + dataConFieldLabels, dataConId, dataConWrapId, + markedStrict, notMarkedStrict, markedUnboxed, dataConRepType ) -import CE ( lookupCE, CE(..) ) -import CmdLineOpts ( GlobalSwitch(..) ) -import E ( getE_TCE, getE_CE, plusGVE, nullGVE, GVE(..), E ) -import ErrUtils ( addShortErrLocLine ) -import Errors ( confusedNameErr, specDataNoSpecErr, specDataUnboxedErr ) -import FiniteMap ( FiniteMap, emptyFM, plusFM, singletonFM ) -import IdInfo ( SpecEnv, mkSpecEnv, SpecInfo(..) ) -import Pretty -import SpecTyFuns ( specialiseConstrTys ) -import TCE -- ( nullTCE, unitTCE, lookupTCE, plusTCE, TCE(..), UniqFM ) -import TVE ( mkTVE, TVE(..) ) -import TcConDecls ( tcConDecls ) -import TcMonoType ( tcMonoType ) -import TcPragmas ( tcDataPragmas, tcTypePragmas ) -import Util +import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId ) +import FieldLabel +import Var ( Id, TyVar ) +import Name ( Name, isLocallyDefined, NamedThing(..) ) +import Outputable +import TyCon ( TyCon, isSynTyCon, isNewTyCon, + tyConDataConsIfAvailable, tyConTyVars, tyConGenIds + ) +import Type ( tyVarsOfTypes, splitFunTy, applyTys, + mkTyConApp, mkTyVarTys, mkForAllTys, + splitAlgTyConApp_maybe, Type + ) +import TysWiredIn ( unitTy ) +import VarSet ( intersectVarSet, isEmptyVarSet ) +import PrelNames ( unpackCStringName, unpackCStringUtf8Name ) +import ListSetOps ( equivClasses ) \end{code} -We consult the @CE@/@TCE@ arguments {\em only} to build knots! - -The resulting @TCE@ has info about the type constructors in it; the -@GVE@ has info about their data constructors. +%************************************************************************ +%* * +\subsection{Type checking} +%* * +%************************************************************************ \begin{code} -tcTyDecls :: E - -> (Name -> Bool) -- given Name, is it an abstract synonym? - -> (Name -> [RenamedDataTypeSig]) -- given Name, get specialisation pragmas - -> [RenamedTyDecl] - -> Baby_TcM (TCE, GVE, - FiniteMap TyCon [(Bool, [Maybe UniType])]) - -- specialisations: - -- True => imported data types i.e. from interface file - -- False => local data types i.e. requsted by source pragmas - -tcTyDecls e _ _ [] = returnB_Tc (nullTCE, nullGVE, emptyFM) - -tcTyDecls e is_abs_syn get_spec_sigs (tyd: tyds) - = tc_decl tyd `thenB_Tc` \ (tce1, gve1, specs1) -> - tcTyDecls e is_abs_syn get_spec_sigs tyds - `thenB_Tc` \ (tce2, gve2, specs2) -> +tcTyDecl1 :: RenamedTyClDecl -> TcM (Name, TyThingDetails) +tcTyDecl1 (TySynonym tycon_name tyvar_names rhs src_loc) + = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> + tcExtendTyVarEnv (tyConTyVars tycon) $ + tcHsType rhs `thenTc` \ rhs_ty -> + -- Note tcHsType not tcHsSigType; we allow type synonyms + -- that aren't types; e.g. type List = [] + -- + -- If the RHS mentions tyvars that aren't in scope, we'll + -- quantify over them: + -- e.g. type T = a->a + -- will become type T = forall a. a->a + -- + -- With gla-exts that's right, but for H98 we should complain. + -- We can now do that here without falling into + -- a black hole, we still do it in rnDecl (TySynonym case) + + returnTc (tycon_name, SynTyDetails rhs_ty) + +tcTyDecl1 (TyData new_or_data context tycon_name _ con_decls _ derivings _ src_loc name1 name2) + = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> let - tce3 = tce1 `plusTCE` tce2 - gve3 = gve1 `plusGVE` gve2 - specs3 = specs1 `plusFM` specs2 + tyvars = tyConTyVars tycon in - returnB_Tc (tce3, gve3, specs3) - where - rec_ce = getE_CE e - rec_tce = getE_TCE e - - -- continued... -\end{code} + tcExtendTyVarEnv tyvars $ -We don't need to substitute here, because the @TCE@s -(which are at the top level) cannot contain free type variables. + -- Typecheck the pieces + tcClassContext context `thenTc` \ ctxt -> + tc_derivs derivings `thenTc` \ derived_classes -> + mapTc (tcConDecl new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons -> -Gather relevant info: -\begin{code} - tc_decl (TyData context name@(PreludeTyCon uniq full_name arity True{-"data"-}) - tyvars con_decls derivings pragmas src_loc) - -- ToDo: context - = tc_data_decl uniq name full_name arity tyvars con_decls - derivings pragmas src_loc - - tc_decl (TyData context name@(OtherTyCon uniq full_name arity True{-"data"-} _) - tyvars con_decls derivings pragmas src_loc) - -- ToDo: context - = tc_data_decl uniq name full_name arity tyvars con_decls - derivings pragmas src_loc - - tc_decl (TyData _ bad_name _ _ _ _ src_loc) - = failB_Tc (confusedNameErr "Bad name on a datatype constructor (a Prelude name?)" - bad_name src_loc) - - tc_decl (TySynonym name@(PreludeTyCon uniq full_name arity False{-"type"-}) - tyvars mono_ty pragmas src_loc) - = tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc - - tc_decl (TySynonym name@(OtherTyCon uniq full_name arity False{-"type"-} _) - tyvars mono_ty pragmas src_loc) - = tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc - - tc_decl (TySynonym bad_name _ _ _ src_loc) - = failB_Tc (confusedNameErr "Bad name on a type-synonym constructor (a Prelude name?)" - bad_name src_loc) + returnTc (tycon_name, DataTyDetails ctxt data_cons derived_classes) + where + tc_derivs Nothing = returnTc [] + tc_derivs (Just ds) = mapTc tcLookupClass ds \end{code} -Real work for @data@ declarations: \begin{code} - tc_data_decl uniq name full_name arity tyvars con_decls derivings pragmas src_loc - = addSrcLocB_Tc src_loc ( - let - (tve, new_tyvars, _) = mkTVE tyvars - rec_tycon = lookupTCE rec_tce name - -- We know the lookup will succeed, because we are just - -- about to put it in the outgoing TCE! +mkNewTyConRep :: TyCon -> Type +-- Find the representation type for this newtype TyCon +-- The trick is to to deal correctly with recursive newtypes +-- such as newtype T = MkT T - spec_sigs = get_spec_sigs name - in - tcSpecDataSigs rec_tce spec_sigs [] `thenB_Tc` \ user_spec_infos -> +mkNewTyConRep tc + = mkForAllTys tvs (loop [] (mkTyConApp tc (mkTyVarTys tvs))) + where + tvs = tyConTyVars tc + loop tcs ty = case splitAlgTyConApp_maybe ty of { + Nothing -> ty ; + Just (tc, tys, data_cons) | not (isNewTyCon tc) -> ty + | tc `elem` tcs -> unitTy + | otherwise -> + + case splitFunTy (applyTys (dataConRepType (head data_cons)) tys) of + (rep_ty, _) -> loop (tc:tcs) rep_ty + } +\end{code} - recoverIgnoreErrorsB_Tc ([], []) ( - tcDataPragmas rec_tce tve rec_tycon new_tyvars pragmas - ) `thenB_Tc` \ (pragma_con_decls, pragma_spec_infos) -> - let - (condecls_to_use, ignore_condecl_errors_if_pragma) - = if null pragma_con_decls then - (con_decls, id) - else - if null con_decls - then (pragma_con_decls, recoverIgnoreErrorsB_Tc nullGVE) - else panic "tcTyDecls:data: user and pragma condecls!" - - (imported_specs, specinfos_to_use) - = if null pragma_spec_infos then - (False, user_spec_infos) - else - if null user_spec_infos - then (True, pragma_spec_infos) - else panic "tcTyDecls:data: user and pragma specinfos!" - - specenv_to_use = mkSpecEnv specinfos_to_use - in - ignore_condecl_errors_if_pragma - (tcConDecls rec_tce tve rec_tycon new_tyvars specenv_to_use condecls_to_use) - `thenB_Tc` \ gve -> - let - condecls = map snd gve - derived_classes = map (lookupCE rec_ce) derivings +%************************************************************************ +%* * +\subsection{Kind and type check constructors} +%* * +%************************************************************************ - new_tycon - = mkDataTyCon uniq - full_name arity new_tyvars condecls - derived_classes - (null pragma_con_decls) - -- if constrs are from pragma we are *abstract* +\begin{code} +kcConDetails :: RenamedContext -> ConDetails Name -> TcM () +kcConDetails ex_ctxt details + = kcHsContext ex_ctxt `thenTc_` + kc_con_details details + where + kc_con_details (VanillaCon btys) = mapTc_ kc_bty btys + kc_con_details (InfixCon bty1 bty2) = mapTc_ kc_bty [bty1,bty2] + kc_con_details (RecCon flds) = mapTc_ kc_field flds - spec_list - = [(imported_specs, maybe_tys) | (SpecInfo maybe_tys _ _) <- specinfos_to_use] + kc_field (_, bty) = kc_bty bty - spec_map - = if null spec_list then - emptyFM - else - singletonFM rec_tycon spec_list - in - returnB_Tc (unitTCE uniq new_tycon, gve, spec_map) - -- It's OK to return pragma condecls in gve, even - -- though some of those names should be "invisible", - -- because the *renamer* is supposed to have dealt with - -- naming/scope issues already. - ) -\end{code} + kc_bty bty = kcHsSigType (getBangType bty) -Real work for @type@ (synonym) declarations: -\begin{code} - tc_syn_decl uniq name full_name arity tyvars mono_ty pragmas src_loc - = addSrcLocB_Tc src_loc ( +tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM DataCon - let (tve, new_tyvars, _) = mkTVE tyvars - in - tcMonoType rec_ce rec_tce tve mono_ty `thenB_Tc` \ expansion -> +tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc) + = tcAddSrcLoc src_loc $ + tcHsTyVars ex_tvs (kcConDetails ex_ctxt details) $ \ ex_tyvars -> + tcClassContext ex_ctxt `thenTc` \ ex_theta -> + case details of + VanillaCon btys -> tc_datacon ex_tyvars ex_theta btys + InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2] + RecCon fields -> tc_rec_con ex_tyvars ex_theta fields + where + tc_sig_type = case new_or_data of + DataType -> tcHsSigType + NewType -> tcHsBoxedSigType + -- Can't allow an unboxed type here, because we're effectively + -- going to remove the constructor while coercing it to a boxed type. + + tc_datacon ex_tyvars ex_theta btys + = let + arg_stricts = map getBangStrictness btys + tys = map getBangType btys + in + mapTc tc_sig_type tys `thenTc` \ arg_tys -> + mk_data_con ex_tyvars ex_theta arg_stricts arg_tys [] + + tc_rec_con ex_tyvars ex_theta fields + = checkTc (null ex_tyvars) (exRecConErr name) `thenTc_` + mapTc tc_field (fields `zip` allFieldLabelTags) `thenTc` \ field_labels_s -> let - -- abstractness info either comes from the interface pragmas - -- (tcTypePragmas) or from a user-pragma in this module - -- (is_abs_syn) - abstract = tcTypePragmas pragmas - || is_abs_syn name - - new_tycon = mkSynonymTyCon uniq full_name - arity new_tyvars expansion (not abstract) + field_labels = concat field_labels_s + arg_stricts = [str | (ns, bty) <- fields, + let str = getBangStrictness bty, + n <- ns -- One for each. E.g x,y,z :: !Int + ] in - returnB_Tc (unitTCE uniq new_tycon, nullGVE, emptyFM) - ) + mk_data_con ex_tyvars ex_theta arg_stricts + (map fieldLabelType field_labels) field_labels + + tc_field ((field_label_names, bty), tag) + = tc_sig_type (getBangType bty) `thenTc` \ field_ty -> + returnTc [mkFieldLabel (getName name) tycon field_ty tag | name <- field_label_names] + + mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields + = let + data_con = mkDataCon name arg_stricts fields + tyvars (thinContext arg_tys ctxt) + ex_tyvars ex_theta + arg_tys + tycon data_con_id data_con_wrap_id + + data_con_id = mkDataConId wkr_name data_con + data_con_wrap_id = mkDataConWrapId data_con + in + returnNF_Tc data_con + +-- The context for a data constructor should be limited to +-- the type variables mentioned in the arg_tys +thinContext arg_tys ctxt + = filter in_arg_tys ctxt + where + arg_tyvars = tyVarsOfTypes arg_tys + in_arg_tys (clas,tys) = not $ isEmptyVarSet $ + tyVarsOfTypes tys `intersectVarSet` arg_tyvars + +getBangStrictness (Banged _) = markedStrict +getBangStrictness (Unbanged _) = notMarkedStrict +getBangStrictness (Unpacked _) = markedUnboxed \end{code} + + %************************************************************************ %* * -\subsection{Specialisation Signatures for Data Type declarations} +\subsection{Generating constructor/selector bindings for data declarations} %* * %************************************************************************ -@tcSpecDataSigs@ checks data type specialisation signatures for -validity, and returns the list of specialisation requests. - \begin{code} -tcSpecDataSigs :: TCE - -> [RenamedDataTypeSig] - -> [(RenamedDataTypeSig,SpecInfo)] - -> Baby_TcM [SpecInfo] - -tcSpecDataSigs tce (s:ss) accum - = tc_sig s `thenB_Tc` \ info -> - tcSpecDataSigs tce ss ((s,info):accum) +mkImplicitDataBinds :: [TyCon] -> TcM ([Id], TcMonoBinds) +mkImplicitDataBinds [] = returnTc ([], EmptyMonoBinds) +mkImplicitDataBinds (tycon : tycons) + | isSynTyCon tycon = mkImplicitDataBinds tycons + | otherwise = mkImplicitDataBinds_one tycon `thenTc` \ (ids1, b1) -> + mkImplicitDataBinds tycons `thenTc` \ (ids2, b2) -> + returnTc (ids1++ids2, b1 `AndMonoBinds` b2) + +mkImplicitDataBinds_one tycon + = mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids -> + let + unf_ids = sel_ids ++ data_con_wrapper_ids ++ gen_ids + all_ids = map dataConId data_cons ++ unf_ids + + -- For the locally-defined things + -- we need to turn the unfoldings inside the selector Ids into bindings, + -- and build bindigns for the constructor wrappers + binds | isLocallyDefined tycon = idsToMonoBinds unf_ids + | otherwise = EmptyMonoBinds + in + returnTc (all_ids, binds) where - tc_sig (SpecDataSig n ty src_loc) - = addSrcLocB_Tc src_loc ( - let - ty_names = extractMonoTyNames (==) ty - (tve,_,_) = mkTVE ty_names - fake_CE = panic "tcSpecDataSigs:CE" - in - -- Typecheck specialising type (includes arity check) - tcMonoType fake_CE tce tve ty `thenB_Tc` \ tau_ty -> - let - (_,ty_args,_) = getUniDataTyCon tau_ty - is_unboxed_or_tyvar ty = isUnboxedDataType ty || isTyVarTemplateTy ty - in - -- Check at least one unboxed type in specialisation - checkB_Tc (not (any isUnboxedDataType ty_args)) - (specDataNoSpecErr n ty_args src_loc) `thenB_Tc_` - - -- Check all types are unboxed or tyvars - -- (specific boxed types are redundant) - checkB_Tc (not (all is_unboxed_or_tyvar ty_args)) - (specDataUnboxedErr n ty_args src_loc) `thenB_Tc_` + data_cons = tyConDataConsIfAvailable tycon + -- Abstract types mean we don't bring the + -- data cons into scope, which should be fine + gen_ids = tyConGenIds tycon + data_con_wrapper_ids = map dataConWrapId data_cons + + fields = [ (con, field) | con <- data_cons, + field <- dataConFieldLabels con + ] + + -- groups is list of fields that share a common name + groups = equivClasses cmp_name fields + cmp_name (_, field1) (_, field2) + = fieldLabelName field1 `compare` fieldLabelName field2 +\end{code} - let - maybe_tys = specialiseConstrTys ty_args - in - returnB_Tc (SpecInfo maybe_tys 0 (panic "SpecData:SpecInfo:SpecId")) - ) - -tcSpecDataSigs tce [] accum - = -- Remove any duplicates from accumulated specinfos - getSwitchCheckerB_Tc `thenB_Tc` \ sw_chkr -> - - (if sw_chkr SpecialiseTrace && not (null duplicates) then - pprTrace "Duplicate SPECIALIZE data pragmas:\n" - (ppAboves (map specmsg sep_dups)) - else id)( - - (if sw_chkr SpecialiseTrace && not (null spec_infos) then - pprTrace "Specialising " - (ppHang (ppCat [ppr PprDebug name, ppStr "at types:"]) - 4 (ppAboves (map pp_spec spec_infos))) - - else id) ( - - returnB_Tc (spec_infos) - )) +\begin{code} +mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) + -- These fields all have the same name, but are from + -- different constructors in the data type + -- 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 (== field_ty) other_tys) + (fieldTypeMisMatch field_name) `thenTc_` + tcLookupGlobalId unpackCStringName `thenTc` \ unpack_id -> + tcLookupGlobalId unpackCStringUtf8Name `thenTc` \ unpackUtf8_id -> + returnTc (mkRecordSelId tycon first_field_label unpack_id unpackUtf8_id) where - spec_infos = map (snd . head) equiv - - equiv = equivClasses cmp_info accum - duplicates = filter (not . singleton) equiv - - cmp_info (_, SpecInfo tys1 _ _) (_, SpecInfo tys2 _ _) - = cmpUniTypeMaybeList tys1 tys2 + field_ty = fieldLabelType first_field_label + field_name = fieldLabelName first_field_label + other_tys = [fieldLabelType fl | (_, fl) <- other_fields] +\end{code} - singleton [_] = True - singleton _ = False - sep_dups = tail (concat (map ((:) Nothing . map Just) duplicates)) - specmsg (Just (SpecDataSig _ ty locn, _)) - = addShortErrLocLine locn ( \ sty -> ppr sty ty ) PprDebug - specmsg Nothing - = ppStr "***" +Errors and contexts +~~~~~~~~~~~~~~~~~~~ +\begin{code} +fieldTypeMisMatch field_name + = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)] - ((SpecDataSig name _ _, _):_) = accum - pp_spec (SpecInfo tys _ _) = ppInterleave ppNil [pprMaybeTy PprDebug ty | ty <- tys] +exRecConErr name + = ptext SLIT("Can't combine named fields with locally-quantified type variables") + $$ + (ptext SLIT("In the declaration of data constructor") <+> ppr name) \end{code}