X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FBuildTyCl.lhs;h=6fb8d92d548c9fb6c1421a9d6bf50b95158412e2;hb=015aa9723a1e72d7bfe0e82599454bee59f4d472;hp=8624ff9349da3eb05e8f1bc3b434df59e3990d31;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/BuildTyCl.lhs b/ghc/compiler/iface/BuildTyCl.lhs index 8624ff9..6fb8d92 100644 --- a/ghc/compiler/iface/BuildTyCl.lhs +++ b/ghc/compiler/iface/BuildTyCl.lhs @@ -14,7 +14,6 @@ module BuildTyCl ( import IfaceEnv ( newImplicitBinder ) import TcRnMonad -import Util ( zipLazy ) import DataCon ( DataCon, isNullarySrcDataCon, mkDataCon, dataConFieldLabels, dataConOrigArgTys ) import Var ( tyVarKind, TyVar, Id ) @@ -26,14 +25,14 @@ import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc ) import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId ) import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) ) -import TyCon ( FieldLabel, mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta, +import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta, tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ), - ArgVrcs, AlgTyConRhs(..), newTyConRhs, visibleDataCons ) + ArgVrcs, AlgTyConRhs(..), newTyConRhs ) import Type ( mkArrowKinds, liftedTypeKind, typeKind, tyVarsOfTypes, tyVarsOfPred, splitTyConApp_maybe, mkPredTys, mkTyVarTys, ThetaType, Type, substTyWith, zipTopTvSubst, substTheta ) import Outputable -import List ( nubBy ) +import List ( nub ) \end{code} @@ -48,16 +47,17 @@ buildSynTyCon name tvs rhs_ty arg_vrcs ------------------------------------------------------ buildAlgTyCon :: Name -> [TyVar] + -> ThetaType -- Stupid theta -> AlgTyConRhs -> ArgVrcs -> RecFlag -> Bool -- True <=> want generics functions -> TcRnIf m n TyCon -buildAlgTyCon tc_name tvs rhs arg_vrcs is_rec want_generics - = do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs +buildAlgTyCon tc_name tvs stupid_theta rhs arg_vrcs is_rec want_generics + = do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs stupid_theta rhs fields is_rec want_generics ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind - ; fields = mkTyConFields tycon rhs + ; fields = mkTyConSelIds tycon rhs } ; return tycon } @@ -65,9 +65,9 @@ buildAlgTyCon tc_name tvs rhs arg_vrcs is_rec want_generics mkAbstractTyConRhs :: AlgTyConRhs mkAbstractTyConRhs = AbstractTyCon -mkDataTyConRhs :: Maybe ThetaType -> [DataCon] -> AlgTyConRhs -mkDataTyConRhs mb_theta cons - = DataTyCon mb_theta cons (all isNullarySrcDataCon cons) +mkDataTyConRhs :: [DataCon] -> AlgTyConRhs +mkDataTyConRhs cons + = DataTyCon cons (all isNullarySrcDataCon cons) mkNewTyConRhs :: TyCon -> DataCon -> AlgTyConRhs mkNewTyConRhs tycon con @@ -79,6 +79,7 @@ mkNewTyConRhs tycon con mkNewTyConRep :: TyCon -- The original type constructor -> Type -- Chosen representation type -- (guaranteed not to be another newtype) + -- Free vars of rep = tyConTyVars tc -- Find the representation type for this newtype TyCon -- Remember that the representation type is the *ultimate* representation @@ -102,18 +103,20 @@ mkNewTyConRep tc | tc `elem` tcs = unitTy | otherwise = case splitTyConApp_maybe rhs_ty of - Just (tc', tys) | isNewTyCon tc' - -> substTyWith tc_tvs tys (go (tc:tcs) tc') + Just (tc1, tys) | isNewTyCon tc1 + -> ASSERT( length (tyConTyVars tc1) == length tys ) + substTyWith (tyConTyVars tc1) tys (go (tc:tcs) tc1) other -> rhs_ty where - (tc_tvs, rhs_ty) = newTyConRhs tc + (_tc_tvs, rhs_ty) = newTyConRhs tc ------------------------------------------------------ buildDataCon :: Name -> Bool -> Bool -> [StrictnessMark] -> [Name] -- Field labels - -> [TyVar] -> ThetaType + -> [TyVar] + -> ThetaType -- Does not include the "stupid theta" -> [Type] -> TyCon -> [Type] -> TcRnIf m n DataCon -- A wrapper for DataCon.mkDataCon that @@ -125,8 +128,8 @@ buildDataCon src_name declared_infix vanilla arg_stricts field_lbls = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc -- This last one takes the name of the data constructor in the source - -- code, which (for Haskell source anyway) will be in the SrcDataName name - -- space, and makes it into a "real data constructor name" + -- code, which (for Haskell source anyway) will be in the DataName name + -- space, and puts it into the VarName name space ; let stupid_ctxt = mkDataConStupidTheta tycon arg_tys res_tys @@ -147,26 +150,20 @@ mkDataConStupidTheta tycon arg_tys res_tys where tc_subst = zipTopTvSubst (tyConTyVars tycon) res_tys stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) + -- Start by instantiating the master copy of the + -- stupid theta, taken from the TyCon + arg_tyvars = tyVarsOfTypes arg_tys in_arg_tys pred = not $ isEmptyVarSet $ tyVarsOfPred pred `intersectVarSet` arg_tyvars ------------------------------------------------------ -mkTyConFields :: TyCon -> AlgTyConRhs -> [(FieldLabel,Type,Id)] -mkTyConFields tycon rhs - = -- We'll check later that fields with the same name +mkTyConSelIds :: TyCon -> AlgTyConRhs -> [Id] +mkTyConSelIds tycon rhs + = [ mkRecordSelId tycon fld + | fld <- nub (concatMap dataConFieldLabels (visibleDataCons rhs)) ] + -- We'll check later that fields with the same name -- from different constructors have the same type. - [ (fld, ty, mkRecordSelId tycon fld ty) - | (fld, ty) <- nubBy eq_fld all_fld_tys ] - where - all_fld_tys = concatMap fld_tys_of (visibleDataCons rhs) - fld_tys_of con = dataConFieldLabels con `zipLazy` - dataConOrigArgTys con - -- The laziness means that the type isn't sucked in prematurely - -- Only vanilla datacons have fields at all, and they - -- share the tycon's type variables => datConOrigArgTys will do - - eq_fld (f1,_) (f2,_) = f1 == f2 \end{code} @@ -230,7 +227,7 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs ; rhs = case dict_component_tys of [rep_ty] -> mkNewTyConRhs tycon dict_con - other -> mkDataTyConRhs Nothing [dict_con] + other -> mkDataTyConRhs [dict_con] } ; return clas })}