diff options
| author | simonpj@microsoft.com <unknown> | 2007-04-22 21:35:03 +0000 |
|---|---|---|
| committer | simonpj@microsoft.com <unknown> | 2007-04-22 21:35:03 +0000 |
| commit | 70918cf4a4d61d4752b18f29ce14c7d7f1fbce01 (patch) | |
| tree | 630ec839dc4b34800e7009b2f725bbd3870d6f25 /compiler/main/PprTyThing.hs | |
| parent | 490791568ac1b31fed0d049892e0853c774aa375 (diff) | |
| download | haskell-70918cf4a4d61d4752b18f29ce14c7d7f1fbce01.tar.gz | |
Fixes to datacon wrappers for indexed data types
nominolo@gmail.com pointed out (Trac #1204) that indexed data types
aren't quite right. I investigated and found that the wrapper
functions for indexed data types, generated in MkId, are really very
confusing. In particular, we'd like these combinations to work
newtype + indexed data type
GADT + indexted data type
The wrapper situation gets a bit complicated!
I did a bit of refactoring, and improved matters, I think. I am not
certain that I have gotten it right yet, but I think it's better.
I'm committing it now becuase it's been on my non-backed-up laptop for
a month and I want to get it into the repo. I don't think I've broken
anything, but I don't regard it as 'done'.
Diffstat (limited to 'compiler/main/PprTyThing.hs')
| -rw-r--r-- | compiler/main/PprTyThing.hs | 24 |
1 files changed, 13 insertions, 11 deletions
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 51144ecda0..025004f805 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -18,8 +18,9 @@ module PprTyThing ( import qualified GHC -import GHC ( TyThing(..), SrcLoc ) -import DataCon ( dataConResTys ) +import TyCon ( tyConFamInst_maybe ) +import Type ( pprTypeApp ) +import GHC ( TyThing(..), SrcLoc ) import Outputable -- ----------------------------------------------------------------------------- @@ -66,8 +67,11 @@ pprTyThingHdr exts (ADataCon dataCon) = pprDataConSig exts dataCon pprTyThingHdr exts (ATyCon tyCon) = pprTyConHdr exts tyCon pprTyThingHdr exts (AClass cls) = pprClassHdr exts cls -pprTyConHdr exts tyCon = - addFamily (ptext keyword) <+> ppr_bndr tyCon <+> hsep (map ppr vars) +pprTyConHdr exts tyCon + | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon + = ptext keyword <+> ptext SLIT("instance") <+> pprTypeApp (ppr_bndr tyCon) tys + | otherwise + = ptext keyword <+> opt_family <+> ppr_bndr tyCon <+> hsep (map ppr vars) where vars | GHC.isPrimTyCon tyCon || GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars @@ -77,9 +81,9 @@ pprTyConHdr exts tyCon = | GHC.isNewTyCon tyCon = SLIT("newtype") | otherwise = SLIT("data") - addFamily keytext - | GHC.isOpenTyCon tyCon = keytext <> ptext SLIT(" family") - | otherwise = keytext + opt_family + | GHC.isOpenTyCon tyCon = ptext SLIT("family") + | otherwise = empty pprDataConSig exts dataCon = ppr_bndr dataCon <+> dcolon <+> pprType exts (GHC.dataConType dataCon) @@ -143,10 +147,9 @@ pprDataConDecl exts gadt_style show_label dataCon | otherwise = ppr_bndr dataCon <+> dcolon <+> sep [ ppr_tvs, GHC.pprThetaArrow theta, pp_tau ] where - (tyvars, theta, argTypes) = GHC.dataConSig dataCon + (tyvars, theta, argTypes, res_ty) = GHC.dataConSig dataCon tyCon = GHC.dataConTyCon dataCon labels = GHC.dataConFieldLabels dataCon - res_tys = dataConResTys dataCon qualVars = filter (flip notElem (GHC.tyConTyVars tyCon)) tyvars stricts = GHC.dataConStrictMarks dataCon tys_w_strs = zip stricts argTypes @@ -157,8 +160,7 @@ pprDataConDecl exts gadt_style show_label dataCon hsep (map ppr qualVars) <> dot -- printing out the dataCon as a type signature, in GADT style - pp_tau = foldr add pp_res_ty tys_w_strs - pp_res_ty = GHC.pprTypeApp (ppr_bndr tyCon) res_tys + pp_tau = foldr add (ppr res_ty) tys_w_strs add (str,ty) pp_ty = pprBangTy str ty <+> arrow <+> pp_ty pprParendBangTy (strict,ty) |