X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FDataCon.lhs;h=5211fc8eba9574b8b4d280064ce08d43675870e4;hb=3c8e76dc677b4b427c7696f0f563224b548bf43b;hp=a04f28f28e0587e498bfcd82b33ec44afae170fe;hpb=80c89b80c355b2aaebcd53330e6c6170c3f05aca;p=ghc-hetmet.git diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index a04f28f..5211fc8 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1998 % \section[DataCon]{@DataCon@: Data Constructors} @@ -9,9 +10,8 @@ module DataCon ( ConTag, fIRST_TAG, mkDataCon, dataConRepType, dataConSig, dataConFullSig, - dataConName, dataConTag, dataConTyCon, dataConUserType, + dataConName, dataConIdentity, dataConTag, dataConTyCon, dataConUserType, dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys, - dataConInstTys, dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta, dataConInstArgTys, dataConOrigArgTys, dataConInstOrigArgTys, dataConRepArgTys, @@ -30,27 +30,18 @@ module DataCon ( #include "HsVersions.h" -import Type ( Type, ThetaType, - substTyWith, substTyVar, mkTopTvSubst, - mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTy, mkTyVarTys, - splitTyConApp_maybe, newTyConInstRhs, - mkPredTys, isStrictPred, pprType, mkPredTy - ) -import Coercion ( isEqPred, mkEqPred ) -import TyCon ( TyCon, FieldLabel, tyConDataCons, - isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon, - isNewTyCon, isRecursiveTyCon, tyConFamily_maybe ) -import Class ( Class, classTyCon ) -import Name ( Name, NamedThing(..), nameUnique, mkSysTvName, mkSystemName ) -import Var ( TyVar, CoVar, Id, mkTyVar, tyVarKind, setVarUnique, - mkCoVar ) -import BasicTypes ( Arity, StrictnessMark(..) ) +import Type +import Coercion +import TyCon +import Class +import Name +import Var +import BasicTypes import Outputable -import Unique ( Unique, Uniquable(..) ) -import ListSetOps ( assoc, minusList ) -import Util ( zipEqual, zipWithEqual ) -import List ( partition ) -import Maybes ( expectJust ) +import Unique +import ListSetOps +import Util +import Maybes import FastString \end{code} @@ -262,6 +253,9 @@ data DataCon -- [This is a change (Oct05): previously, vanilla datacons guaranteed to -- have the same type variables as their parent TyCon, but that seems ugly.] + -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames + -- Reason: less confusing, and easier to generate IfaceSyn + dcEqSpec :: [(TyVar,Type)], -- Equalities derived from the result type, -- *as written by the programmer* -- This field allows us to move conveniently between the two ways @@ -315,6 +309,7 @@ data DataCon -- and *including* existential dictionaries dcRepStrictness :: [StrictnessMark], -- One for each *representation* argument + -- See also Note [Data-con worker strictness] in MkId.lhs dcRepType :: Type, -- Type of the constructor -- forall a x y. (a:=:(x,y), Ord x) => x -> y -> MkT a @@ -336,13 +331,9 @@ data DataCon -- An entirely separate wrapper function is built in TcTyDecls dcIds :: DataConIds, - dcInfix :: Bool, -- True <=> declared infix + dcInfix :: Bool -- True <=> declared infix -- Used for Template Haskell and 'deriving' only -- The actual fixity is stored elsewhere - - dcInstTys :: Maybe [Type] -- If this data constructor is part of a - -- data instance, then these are the type - -- patterns of the instance. } data DataConIds @@ -359,7 +350,7 @@ data DataConIds -- The 'Nothing' case of DCIds is important -- Not only is this efficient, -- but it also ensures that the wrapper is replaced - -- by the worker (becuase it *is* the wroker) + -- by the worker (becuase it *is* the worker) -- even when there are no args. E.g. in -- f (:) x -- the (:) *is* the worker. @@ -438,7 +429,6 @@ mkDataCon :: Name -> [TyVar] -> [TyVar] -> [(TyVar,Type)] -> ThetaType -> [Type] -> TyCon - -> Maybe [Type] -> ThetaType -> DataConIds -> DataCon -- Can get the tag from the TyCon @@ -449,17 +439,22 @@ mkDataCon name declared_infix univ_tvs ex_tvs eq_spec theta orig_arg_tys tycon - mb_typats stupid_theta ids +-- Warning: mkDataCon is not a good place to check invariants. +-- If the programmer writes the wrong result type in the decl, thus: +-- data T a where { MkT :: S } +-- then it's possible that the univ_tvs may hit an assertion failure +-- if you pull on univ_tvs. This case is checked by checkValidDataCon, +-- so the error is detected properly... it's just that asaertions here +-- are a little dodgy. + = ASSERT( not (any isEqPred theta) ) -- We don't currently allow any equality predicates on -- a data constructor (apart from the GADT ones in eq_spec) con where is_vanilla = null ex_tvs && null eq_spec && null theta - con = ASSERT( is_vanilla || not (isNewTyCon tycon) ) - -- Invariant: newtypes have a vanilla data-con - MkData {dcName = name, dcUnique = nameUnique name, + con = MkData {dcName = name, dcUnique = nameUnique name, dcVanilla = is_vanilla, dcInfix = declared_infix, dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, @@ -469,8 +464,7 @@ mkDataCon name declared_infix dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts, dcFields = fields, dcTag = tag, dcRepType = ty, - dcIds = ids, - dcInstTys = mb_typats } + dcIds = ids } -- Strictness marks for source-args -- *after unboxing choices*, @@ -507,6 +501,19 @@ mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict dataConName :: DataCon -> Name dataConName = dcName +-- generate a name in the format: package:Module.OccName +-- and the unique identity of the name +dataConIdentity :: DataCon -> String +dataConIdentity dataCon + = prettyName + where + prettyName = pretty packageModule ++ "." ++ pretty occ + nm = getName dataCon + packageModule = nameModule nm + occ = getOccName dataCon + pretty :: Outputable a => a -> String + pretty = showSDoc . ppr + dataConTag :: DataCon -> ConTag dataConTag = dcTag @@ -609,9 +616,6 @@ dataConResTys dc = [substTyVar env tv | tv <- dcUnivTyVars dc] where env = mkTopTvSubst (dcEqSpec dc) -dataConInstTys :: DataCon -> Maybe [Type] -dataConInstTys = dcInstTys - dataConUserType :: DataCon -> Type -- The user-declared type of the data constructor -- in the nice-to-read form @@ -623,18 +627,13 @@ dataConUserType :: DataCon -> Type dataConUserType (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, dcTheta = theta, dcOrigArgTys = arg_tys, - dcTyCon = tycon, dcInstTys = mb_insttys }) + dcTyCon = tycon }) = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ mkFunTys (mkPredTys theta) $ mkFunTys arg_tys $ - case mb_insttys of - Nothing -> mkTyConApp tycon (map (substTyVar subst) univ_tvs) - Just insttys -> mkTyConApp ftycon insttys -- data instance - where - ftycon = case tyConFamily_maybe tycon of - Just ftycon -> ftycon - Nothing -> panic err - err = "dataConUserType: type patterns without family tycon" + case tyConFamInst_maybe tycon of + Nothing -> mkTyConApp tycon (substTyVars subst univ_tvs) + Just (ftc, insttys) -> mkTyConApp ftc insttys -- data instance where subst = mkTopTvSubst eq_spec @@ -645,10 +644,12 @@ dataConInstArgTys :: DataCon -- NB: these INCLUDE the existentially quantified dict args -- but EXCLUDE the data-decl context which is discarded -- It's all post-flattening etc; this is a representation type -dataConInstArgTys (MkData {dcRepArgTys = arg_tys, - dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs}) inst_tys - = ASSERT( length tyvars == length inst_tys ) +dataConInstArgTys dc@(MkData {dcRepArgTys = arg_tys, + dcUnivTyVars = univ_tvs, + dcExTyVars = ex_tvs}) inst_tys + = ASSERT2 ( length tyvars == length inst_tys + , ptext SLIT("dataConInstArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys) + map (substTyWith tyvars inst_tys) arg_tys where tyvars = univ_tvs ++ ex_tvs @@ -657,9 +658,10 @@ dataConInstArgTys (MkData {dcRepArgTys = arg_tys, -- And the same deal for the original arg tys dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, - dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs}) inst_tys - = ASSERT2( length tyvars == length inst_tys, ptext SLIT("dataConInstOrigArgTys") <+> ppr dc <+> ppr inst_tys ) + dcUnivTyVars = univ_tvs, + dcExTyVars = ex_tvs}) inst_tys + = ASSERT2( length tyvars == length inst_tys + , ptext SLIT("dataConInstOrigArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) map (substTyWith tyvars inst_tys) arg_tys where tyvars = univ_tvs ++ ex_tvs @@ -743,9 +745,10 @@ splitProductType str ty deepSplitProductType_maybe ty = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty ; let {result - | isNewTyCon tycon && not (isRecursiveTyCon tycon) + | isClosedNewTyCon tycon && not (isRecursiveTyCon tycon) = deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args) - | isNewTyCon tycon = Nothing -- cannot unbox through recursive newtypes + | isNewTyCon tycon = Nothing -- cannot unbox through recursive + -- newtypes nor through families | otherwise = Just res} ; result } @@ -767,6 +770,6 @@ computeRep stricts tys unbox MarkedStrict ty = [(MarkedStrict, ty)] unbox MarkedUnboxed ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys where - (tycon, tycon_args, arg_dc, arg_tys) + (_tycon, _tycon_args, arg_dc, arg_tys) = deepSplitProductType "unbox_strict_arg_ty" ty \end{code}