X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FDataCon.lhs;h=ee2c6857dc24f4f7d0cfcf78db6784afb3958f2e;hb=7739158ff9d983f80cb269f3c7cb38108e72e8ec;hp=b2e166bceaee62e83ffb217ee7d4426ed1059afb;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index b2e166b..ee2c685 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -10,10 +10,10 @@ module DataCon ( ConTag, fIRST_TAG, mkDataCon, dataConRepType, dataConSig, dataConFullSig, - dataConName, dataConTag, dataConTyCon, dataConUserType, - dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys, + dataConName, dataConIdentity, dataConTag, dataConTyCon, dataConUserType, + dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta, - dataConInstArgTys, dataConOrigArgTys, + dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, dataConInstOrigArgTys, dataConRepArgTys, dataConFieldLabels, dataConFieldType, dataConStrictMarks, dataConExStricts, @@ -233,7 +233,7 @@ data DataCon -- dcEqSpec = [a:=:(x,y)] -- dcTheta = [Ord x] -- dcOrigArgTys = [a,List b] - -- dcTyCon = T + -- dcRepTyCon = T dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor -- Its type is of form @@ -288,9 +288,11 @@ data DataCon dcOrigArgTys :: [Type], -- Original argument types -- (before unboxing and flattening of strict fields) - - -- Result type of constructor is T t1..tn - dcTyCon :: TyCon, -- Result tycon, T + dcOrigResTy :: Type, -- Original result type + -- NB: for a data instance, the original user result type may + -- differ from the DataCon's representation TyCon. Example + -- data instance T [a] where MkT :: a -> T [a] + -- The OrigResTy is T [a], but the dcRepTyCon might be :T123 -- Now the strictness annotations and field labels of the constructor dcStrictMarks :: [StrictnessMark], @@ -300,7 +302,7 @@ data DataCon dcFields :: [FieldLabel], -- Field labels for this constructor, in the - -- same order as the argument types; + -- same order as the dcOrigArgTys; -- length = 0 (if not a record) or dataConSourceArity. -- Constructor representation @@ -309,6 +311,10 @@ data DataCon -- and *including* existential dictionaries dcRepStrictness :: [StrictnessMark], -- One for each *representation* argument + -- See also Note [Data-con worker strictness] in MkId.lhs + + -- Result type of constructor is T t1..tn + dcRepTyCon :: TyCon, -- Result tycon, T dcRepType :: Type, -- Type of the constructor -- forall a x y. (a:=:(x,y), Ord x) => x -> y -> MkT a @@ -349,7 +355,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. @@ -458,7 +464,8 @@ mkDataCon name declared_infix dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, dcStupidTheta = stupid_theta, dcTheta = theta, - dcOrigArgTys = orig_arg_tys, dcTyCon = tycon, + dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, + dcRepTyCon = tycon, dcRepArgTys = rep_arg_tys, dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts, @@ -476,6 +483,22 @@ mkDataCon name declared_infix real_arg_tys = dict_tys ++ orig_arg_tys real_stricts = map mk_dict_strict_mark theta ++ arg_stricts + -- Example + -- data instance T [a] where + -- TI :: forall b. b -> T [Maybe b] + -- The representation tycon looks like this: + -- data :R7T a where + -- TI :: forall b c. (c :=: Maybe b) b -> :R7T c + orig_res_ty + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tycon + , let fam_subst = zipTopTvSubst (tyConTyVars fam_tc) res_tys + = mkTyConApp fam_tc (substTys fam_subst fam_tys) + | otherwise + = mkTyConApp tycon res_tys + where + res_tys = substTyVars (mkTopTvSubst eq_spec) univ_tvs + -- In the example above, res_tys is a singleton, (Maybe b) + -- Representation arguments and demands -- To do: eliminate duplication with MkId (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys @@ -500,11 +523,24 @@ 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 dataConTyCon :: DataCon -> TyCon -dataConTyCon = dcTyCon +dataConTyCon = dcRepTyCon dataConRepType :: DataCon -> Type dataConRepType = dcRepType @@ -583,25 +619,23 @@ dataConRepStrictness :: DataCon -> [StrictnessMark] -- Core constructor application (Con dc args) dataConRepStrictness dc = dcRepStrictness dc -dataConSig :: DataCon -> ([TyVar], ThetaType, [Type]) +dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type) dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcTheta = theta, dcOrigArgTys = arg_tys, dcTyCon = tycon}) - = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys) + dcTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty) dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type]) + -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type) dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcTheta = theta, dcOrigArgTys = arg_tys, dcTyCon = tycon}) - = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) + dcTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) + +dataConOrigResTy :: DataCon -> Type +dataConOrigResTy dc = dcOrigResTy dc dataConStupidTheta :: DataCon -> ThetaType dataConStupidTheta dc = dcStupidTheta dc -dataConResTys :: DataCon -> [Type] -dataConResTys dc = [substTyVar env tv | tv <- dcUnivTyVars dc] - where - env = mkTopTvSubst (dcEqSpec dc) - dataConUserType :: DataCon -> Type -- The user-declared type of the data constructor -- in the nice-to-read form @@ -613,15 +647,11 @@ dataConUserType :: DataCon -> Type dataConUserType (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, dcTheta = theta, dcOrigArgTys = arg_tys, - dcTyCon = tycon }) + dcOrigResTy = res_ty }) = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ mkFunTys (mkPredTys theta) $ mkFunTys arg_tys $ - case tyConFamInst_maybe tycon of - Nothing -> mkTyConApp tycon (map (substTyVar subst) univ_tvs) - Just (ftc, insttys) -> mkTyConApp ftc insttys -- data instance - where - subst = mkTopTvSubst eq_spec + res_ty dataConInstArgTys :: DataCon -> [Type] -- Instantiated at these types @@ -630,10 +660,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 @@ -642,9 +674,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 @@ -669,10 +702,10 @@ dataConRepArgTys dc = dcRepArgTys dc \begin{code} isTupleCon :: DataCon -> Bool -isTupleCon (MkData {dcTyCon = tc}) = isTupleTyCon tc +isTupleCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc isUnboxedTupleCon :: DataCon -> Bool -isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc +isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc isVanillaDataCon :: DataCon -> Bool isVanillaDataCon dc = dcVanilla dc @@ -683,6 +716,7 @@ isVanillaDataCon dc = dcVanilla dc classDataCon :: Class -> DataCon classDataCon clas = case tyConDataCons (classTyCon clas) of (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr + [] -> panic "classDataCon" \end{code} %************************************************************************