[project @ 2003-02-12 15:01:31 by simonpj]

[ghc-hetmet.git] / ghc / compiler / main / MkIface.lhs

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 4317be4..2b35f37 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -24,12 +24,12 @@ import NewDemand    ( isTopSig )
 import TcRnMonad
 import TcRnTypes       ( ImportAvails(..) )
 import RnHsSyn         ( RenamedInstDecl, RenamedTyClDecl )
-import HscTypes                ( VersionInfo(..), ModIface(..), HomeModInfo(..),
+import HscTypes                ( VersionInfo(..), ModIface(..), 
                          ModGuts(..), ModGuts, 
-                         GhciMode(..), HscEnv(..),
+                         GhciMode(..), HscEnv(..), Dependencies(..),
                          FixityEnv, lookupFixity, collectFixities,
                          IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
-                         TyThing(..), DFunId, Dependencies,
+                         TyThing(..), DFunId, 
                          Avails, AvailInfo, GenAvailInfo(..), availName, 
                          ExternalPackageState(..),
                          ParsedIface(..), Usage(..),
@@ -39,7 +39,7 @@ import HscTypes               ( VersionInfo(..), ModIface(..), HomeModInfo(..),
 
 import CmdLineOpts
 import Id              ( idType, idInfo, isImplicitId, idCgInfo )
-import DataCon         ( dataConSig, dataConFieldLabels, dataConStrictMarks )
+import DataCon         ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks )
 import IdInfo          -- Lots
 import CoreSyn         ( CoreRule(..), IdCoreRule )
 import CoreFVs         ( ruleLhsFreeNames )
@@ -55,21 +55,22 @@ import TyCon                ( DataConDetails(..), tyConTyVars, tyConDataCons, tyConTheta,
                          getSynTyConDefn, tyConGenInfo, tyConDataConDetails, tyConArity )
 import Class           ( classExtraBigSig, classTyCon, DefMeth(..) )
 import FieldLabel      ( fieldLabelType )
-import TcType          ( tcSplitSigmaTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead )
+import TcType          ( tcSplitForAllTys, tcFunResultTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead )
 import SrcLoc          ( noSrcLoc )
 import Module          ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule,
                          ModLocation(..), mkSysModuleNameFS, 
-                         ModuleEnv, emptyModuleEnv, foldModuleEnv, lookupModuleEnv,
-                         extendModuleEnv_C, elemModuleSet, moduleEnvElts, elemModuleEnv
+                         ModuleEnv, emptyModuleEnv, lookupModuleEnv,
+                         extendModuleEnv_C, moduleEnvElts 
                        )
 import Outputable
 import Util            ( sortLt, dropList, seqList )
 import Binary          ( getBinFileWithDict )
-import BinIface                ( writeBinIface )
+import BinIface                ( writeBinIface, v_IgnoreHiVersion )
 import ErrUtils                ( dumpIfSet_dyn )
 import FiniteMap
 import FastString
 
+import DATA_IOREF      ( writeIORef )
 import Monad           ( when )
 import Maybe           ( catMaybes, isJust, isNothing )
 import Maybes          ( orElse )
@@ -86,6 +87,9 @@ import IO             ( putStrLn )
 \begin{code}
 showIface :: FilePath -> IO ()
 showIface filename = do
+   -- skip the version check; we don't want to worry about profiled vs.
+   -- non-profiled interfaces, for example.
+   writeIORef v_IgnoreHiVersion True
    parsed_iface <- Binary.getBinFileWithDict filename
    let ParsedIface{
       pi_mod=pi_mod, pi_pkg=pi_pkg, pi_vers=pi_vers,
@@ -220,6 +224,7 @@ we miss them out of the accumulating parameter here.
 
 \begin{code}
 ifaceTyThing_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
+ifaceTyThing_acc (ADataCon dc) so_far                = so_far
 ifaceTyThing_acc (AnId   id) so_far | isImplicitId id = so_far
 ifaceTyThing_acc (ATyCon id) so_far | isClassTyCon id = so_far
 ifaceTyThing_acc other so_far = ifaceTyThing other : so_far
@@ -246,13 +251,15 @@ ifaceTyThing (AClass clas) = cls_decl
 
     toClassOpSig (sel_id, def_meth)
        = ASSERT(sel_tyvars == clas_tyvars)
-         ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc
+         ClassOpSig (getName sel_id) def_meth (toHsType op_ty) noSrcLoc
        where
-         (sel_tyvars, _, op_ty) = tcSplitSigmaTy (idType sel_id)
-         def_meth' = case def_meth of
-                        NoDefMeth  -> NoDefMeth
-                        GenDefMeth -> GenDefMeth
-                        DefMeth id -> DefMeth (getName id)
+               -- Be careful when splitting the type, because of things
+               -- like         class Foo a where
+               --                op :: (?x :: String) => a -> a
+               -- and          class Baz a where
+               --                op :: (Ord a) => a -> a
+         (sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id)
+         op_ty                = tcFunResultTy rho_ty
 
 ifaceTyThing (ATyCon tycon) = ty_decl
   where
@@ -302,7 +309,7 @@ ifaceTyThing (ATyCon tycon) = ty_decl
     ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)
 
     ifaceConDecl data_con 
-       = ConDecl (getName data_con)
+       = ConDecl (dataConName data_con)
                  (toHsTyVars ex_tyvars)
                  (toHsContext ex_theta)
                  details noSrcLoc
@@ -476,7 +483,7 @@ mkUsageInfo :: HscEnv -> ExternalPackageState
 
 mkUsageInfo hsc_env eps
            (ImportAvails { imp_mods = dir_imp_mods,
-                           dep_mods = dep_mods })
+                           imp_dep_mods = dep_mods })
            used_names
   = -- seq the list of Usages returned: occasionally these
     -- don't get evaluated for a while and we can end up hanging on to
@@ -484,7 +491,7 @@ mkUsageInfo hsc_env eps
     usages `seqList` usages
   where
     usages = catMaybes [ mkUsage mod_name 
-                      | (mod_name,_,_) <- moduleEnvElts dep_mods]
+                      | (mod_name,_) <- moduleEnvElts dep_mods]
 
     hpt = hsc_HPT hsc_env
     pit = eps_PIT eps
@@ -781,16 +788,15 @@ pprUsage getOcc usage
 
 
 pprDeps :: Dependencies -> SDoc
-pprDeps (mods, pkgs)
+pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs})
   = vcat [ptext SLIT("module dependencies:") <+> fsep (map ppr_mod mods),
-         ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs)]
+         ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs), 
+         ptext SLIT("orphans:") <+> fsep (map ppr orphs)
+       ]
   where
-    ppr_mod (mod_name, orph, boot)
-      = ppr mod_name <+> ppr_orphan orph <+> ppr_boot boot
+    ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
    
-    ppr_orphan True  = char '!'
-    ppr_orphan False = empty
-    ppr_boot   True  = char '@'
+    ppr_boot   True  = text "[boot]"
     ppr_boot   False = empty
 \end{code}