X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FDataCon.lhs;h=9ce966ee7743dbbfff37e6288f352bd5f5d10374;hb=43d903cfaafb0b41242af128c7ddbf0b649f63bd;hp=a3504a627c94dcf4a871434e6d93bf748b09c663;hpb=683a26900e9170ba57c561a2dc94a3a4eb38cfdf;p=ghc-hetmet.git diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index a3504a6..9ce966e 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -43,6 +43,11 @@ import ListSetOps import Util import Maybes import FastString +import PackageConfig +import Module + +import Data.Char +import Data.Word \end{code} @@ -492,18 +497,7 @@ mkDataCon name declared_infix -- The representation tycon looks like this: -- data :R7T b c where -- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 - - orig_res_ty - | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tycon - , let fam_subst = zipTopTvSubst (tyConTyVars tycon) 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, - -- univ_tvs = [ b1, c1 ] - -- res_tys = [ b1, b1 ] + orig_res_ty = mkFamilyTyConApp tycon (substTyVars (mkTopTvSubst eq_spec) univ_tvs) -- Representation arguments and demands -- To do: eliminate duplication with MkId @@ -529,19 +523,6 @@ 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 @@ -645,9 +626,9 @@ dataConStupidTheta dc = dcStupidTheta dc dataConUserType :: DataCon -> Type -- The user-declared type of the data constructor -- in the nice-to-read form --- T :: forall a. a -> T [a] +-- T :: forall a b. a -> b -> T [a] -- rather than --- T :: forall b. forall a. (a=[b]) => a -> T b +-- T :: forall a c. forall b. (c=[a]) => a -> b -> T c -- NB: If the constructor is part of a data instance, the result type -- mentions the family tycon, not the internal one. dataConUserType (MkData { dcUnivTyVars = univ_tvs, @@ -659,34 +640,37 @@ dataConUserType (MkData { dcUnivTyVars = univ_tvs, mkFunTys arg_tys $ res_ty -dataConInstArgTys :: DataCon +dataConInstArgTys :: DataCon -- A datacon with no existentials or equality constraints + -- However, it can have a dcTheta (notably it can be a + -- class dictionary, with superclasses) -> [Type] -- Instantiated at these types - -- NB: these INCLUDE the existentially quantified arg types -> [Type] -- Needs arguments of these types - -- NB: these INCLUDE the existentially quantified dict args + -- NB: these INCLUDE any dict args -- but EXCLUDE the data-decl context which is discarded -- It's all post-flattening etc; this is a representation type -dataConInstArgTys dc@(MkData {dcRepArgTys = arg_tys, - dcUnivTyVars = univ_tvs, +dataConInstArgTys dc@(MkData {dcRepArgTys = rep_arg_tys, + dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec, 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 - - --- And the same deal for the original arg tys -dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] + = ASSERT2 ( length univ_tvs == length inst_tys + , ptext SLIT("dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) + ASSERT2 ( null ex_tvs && null eq_spec, ppr dc ) + map (substTyWith univ_tvs inst_tys) rep_arg_tys + +dataConInstOrigArgTys + :: DataCon -- Works for any DataCon + -> [Type] -- Includes existential tyvar args, but NOT + -- equality constraints or dicts + -> [Type] -- Returns just the instsantiated *value* arguments +-- For vanilla datacons, it's all quite straightforward +-- But for the call in MatchCon, we really do want just the value args dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs}) inst_tys - = ASSERT2( length tyvars == length 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 + map (substTyWith tyvars inst_tys) arg_tys + where + tyvars = univ_tvs ++ ex_tvs \end{code} These two functions get the real argument types of the constructor, @@ -705,6 +689,19 @@ dataConRepArgTys :: DataCon -> [Type] dataConRepArgTys dc = dcRepArgTys dc \end{code} +The string :. identifying a constructor, which is attached +to its info table and used by the GHCi debugger and the heap profiler. We want +this string to be UTF-8, so we get the bytes directly from the FastStrings. + +\begin{code} +dataConIdentity :: DataCon -> [Word8] +dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++ + fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++ + fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name)) + where name = dataConName dc + mod = nameModule name +\end{code} + \begin{code} isTupleCon :: DataCon -> Bool @@ -756,7 +753,8 @@ splitProductType_maybe ty -- and for constructors visible -> Just (tycon, ty_args, data_con, dataConInstArgTys data_con ty_args) where - data_con = head (tyConDataCons tycon) + data_con = ASSERT( not (null (tyConDataCons tycon)) ) + head (tyConDataCons tycon) other -> Nothing splitProductType str ty