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.

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 793b56d..26d6fab 100644 (file)
--- 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 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 )
 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]
 
 \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 (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)
                               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 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
 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 (file)
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -17,7 +17,9 @@ module PprTyThing (
 #include "HsVersions.h"
 
 import qualified GHC
 #include "HsVersions.h"
 
 import qualified GHC

+

 import GHC ( TyThing(..), SrcLoc )
 import GHC ( TyThing(..), SrcLoc )

+import DataCon ( dataConResTys )

 import Outputable
 
 -- -----------------------------------------------------------------------------
 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
   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
   | 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
     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
     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))))
        = ppr_bndr dataCon <+> 
                braces (sep (punctuate comma (ppr_trim maybe_show_label 
                                        (zip labels fields))))

-
+-}

 pprClass exts cls
   | null methods = 
        pprClassHdr exts cls
 pprClass exts cls
   | null methods = 
        pprClassHdr exts cls