Fix free-variable finder

[ghc-hetmet.git] / ghc / compiler / iface / IfaceType.lhs

diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs
index f893a58..76438dd 100644 (file)
--- a/ghc/compiler/iface/IfaceType.lhs
+++ b/ghc/compiler/iface/IfaceType.lhs
@@ -15,6 +15,7 @@ module IfaceType (
        -- Conversion from Type -> IfaceType
        toIfaceType, toIfacePred, toIfaceContext, 
        toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, 
+       toIfaceTyCon, toIfaceTyCon_name,
 
        -- Printing
        pprIfaceType, pprParendIfaceType, pprIfaceContext, 
@@ -26,12 +27,13 @@ module IfaceType (
 #include "HsVersions.h"
 
 import Kind            ( Kind(..) )
-import TypeRep         ( Type(..), TyNote(..), PredType(..), ThetaType )
-import TyCon           ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity )
+import TypeRep         ( TyThing(..), Type(..), PredType(..), ThetaType )
+import TyCon           ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity, tyConName )
 import Var             ( isId, tyVarKind, idType )
 import TysWiredIn      ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName )
 import OccName         ( OccName, parenSymOcc )
-import Name            ( Name, getName, getOccName, nameModule, nameOccName )
+import Name            ( Name, getName, getOccName, nameModule, nameOccName,
+                         wiredInNameTyThing_maybe )
 import Module          ( Module )
 import BasicTypes      ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity )
 import Outputable
@@ -307,10 +309,13 @@ instance Outputable IfaceTyCon where
 -------------------
 pprIfaceContext :: IfaceContext -> SDoc
 -- Prints "(C a, D b) =>", including the arrow
-pprIfaceContext []    = empty
-pprIfaceContext theta = parens (sep (punctuate comma (map ppr theta))) 
-                       <+> ptext SLIT("=>")
-  
+pprIfaceContext []     = empty
+pprIfaceContext theta = ppr_preds theta <+> ptext SLIT("=>")
+
+ppr_preds [pred] = ppr pred    -- No parens
+ppr_preds preds  = parens (sep (punctuate comma (map ppr preds))) 
+                        
+-------------------
 pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
 \end{code}
 
@@ -332,18 +337,37 @@ toIfaceBndr ext var
 
 ---------------------
 toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType
+-- Synonyms are retained in the interface type
 toIfaceType ext (TyVarTy tv)                = IfaceTyVar (getOccName tv)
 toIfaceType ext (AppTy t1 t2)               = IfaceAppTy (toIfaceType ext t1) (toIfaceType ext t2)
 toIfaceType ext (FunTy t1 t2)               = IfaceFunTy (toIfaceType ext t1) (toIfaceType ext t2)
-toIfaceType ext (TyConApp tc tys)           = IfaceTyConApp (mkIfaceTc ext tc) (toIfaceTypes ext tys)
+toIfaceType ext (TyConApp tc tys)           = IfaceTyConApp (toIfaceTyCon ext tc) (toIfaceTypes ext tys)
 toIfaceType ext (ForAllTy tv t)             = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType ext t)
 toIfaceType ext (PredTy st)                 = IfacePredTy (toIfacePred ext st)
-toIfaceType ext (NoteTy (SynNote tc_app) ty) = toIfaceType ext tc_app  -- Retain synonyms
 toIfaceType ext (NoteTy other_note ty)      = toIfaceType ext ty
 
 ----------------
-mkIfaceTc :: (Name -> IfaceExtName) -> TyCon -> IfaceTyCon
-mkIfaceTc ext tc 
+-- A little bit of (perhaps optional) trickiness here.  When
+-- compiling Data.Tuple, the tycons are not TupleTyCons, although
+-- they have a wired-in name.  But we'd like to dump them into the Iface
+-- as a tuple tycon, to save lookups when reading the interface
+-- Hence a tuple tycon may 'miss' in toIfaceTyCon, but then
+-- toIfaceTyCon_name will still catch it.
+
+toIfaceTyCon :: (Name -> IfaceExtName) -> TyCon -> IfaceTyCon
+toIfaceTyCon ext tc 
+  | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc)
+  | otherwise      = toIfaceTyCon_name ext (tyConName tc)
+
+toIfaceTyCon_name :: (Name -> IfaceExtName) -> Name -> IfaceTyCon
+toIfaceTyCon_name ext nm
+  | Just (ATyCon tc) <- wiredInNameTyThing_maybe nm
+  = toIfaceWiredInTyCon ext tc nm
+  | otherwise
+  = IfaceTc (ext nm)
+
+toIfaceWiredInTyCon :: (Name -> IfaceExtName) -> TyCon -> Name -> IfaceTyCon
+toIfaceWiredInTyCon ext tc nm
   | isTupleTyCon tc     = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc)
   | nm == intTyConName  = IfaceIntTc
   | nm == boolTyConName = IfaceBoolTc 
@@ -351,8 +375,6 @@ mkIfaceTc ext tc
   | nm == listTyConName = IfaceListTc 
   | nm == parrTyConName = IfacePArrTc 
   | otherwise          = IfaceTc (ext nm)
-  where
-    nm = getName tc
 
 ----------------
 toIfaceTypes ext ts = map (toIfaceType ext) ts