From 2a6d497b719b39d7d7d73051f3baa783db343abb Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 4 Aug 2006 22:04:23 +0000 Subject: [PATCH] Massive patch for the first months work adding System FC to GHC #24 Broken up massive patch -=chak Original log message: This is (sadly) all done in one patch to avoid Darcs bugs. It's not complete work... more FC stuff to come. A compiler using just this patch will fail dismally. --- compiler/main/HscTypes.lhs | 11 +++++++++-- compiler/main/PprTyThing.hs | 9 +++++++-- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 793b56d..26d6fab 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -83,7 +83,7 @@ import Id ( Id ) import Type ( TyThing(..) ) import Class ( Class, classSelIds, classTyCon ) -import TyCon ( TyCon, tyConSelIds, tyConDataCons ) +import TyCon ( TyCon, tyConSelIds, tyConDataCons, isNewTyCon, newTyConCo ) import DataCon ( dataConImplicitIds ) import PrelNames ( gHC_PRIM ) import Packages ( PackageId ) @@ -618,13 +618,16 @@ mkPrintUnqualified env = (qual_name, qual_mod) \begin{code} implicitTyThings :: TyThing -> [TyThing] +-- If you change this, make sure you change LoadIface.ifaceDeclSubBndrs in sync + implicitTyThings (AnId id) = [] -- For type constructors, add the data cons (and their extras), -- and the selectors and generic-programming Ids too -- -- Newtypes don't have a worker Id, so don't generate that? -implicitTyThings (ATyCon tc) = map AnId (tyConSelIds tc) ++ +implicitTyThings (ATyCon tc) = implicitNewCoTyCon tc ++ + map AnId (tyConSelIds tc) ++ concatMap (extras_plus . ADataCon) (tyConDataCons tc) -- For classes, add the class TyCon too (and its extras) @@ -636,6 +639,10 @@ implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++ -- For data cons add the worker and wrapper (if any) implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) + -- For newtypes, add the implicit coercion tycon +implicitNewCoTyCon tc | isNewTyCon tc = [ATyCon (newTyConCo tc)] + | otherwise = [] + extras_plus thing = thing : implicitTyThings thing extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 2763b05..6354984 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -17,7 +17,9 @@ module PprTyThing ( #include "HsVersions.h" import qualified GHC + import GHC ( TyThing(..), SrcLoc ) +import DataCon ( dataConResTys ) import Outputable -- ----------------------------------------------------------------------------- @@ -129,12 +131,15 @@ pprDataCon exts dataCon = pprAlgTyCon exts tyCon (== dataCon) (const True) where tyCon = GHC.dataConTyCon dataCon pprDataConDecl exts gadt_style show_label dataCon + = error "kevind stub" +{- | not gadt_style = ppr_fields tys_w_strs | otherwise = ppr_bndr dataCon <+> dcolon <+> sep [ ppr_tvs, GHC.pprThetaArrow theta, pp_tau ] where - (tyvars, theta, argTypes, tyCon, res_tys) = GHC.dataConSig dataCon + (tyvars, theta, argTypes, tyCon) = GHC.dataConSig 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 @@ -171,7 +176,7 @@ pprDataConDecl exts gadt_style show_label dataCon = ppr_bndr dataCon <+> braces (sep (punctuate comma (ppr_trim maybe_show_label (zip labels fields)))) - +-} pprClass exts cls | null methods = pprClassHdr exts cls -- 1.7.10.4