[project @ 2003-07-21 15:14:18 by ross]

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

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 5399ec1..49d428f 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -38,8 +38,8 @@ import HscTypes               ( VersionInfo(..), ModIface(..),
                        )
 
 import CmdLineOpts
-import Id              ( idType, idInfo, isImplicitId, idCgInfo )
-import DataCon         ( dataConSig, dataConFieldLabels, dataConStrictMarks )
+import Id              ( idType, idInfo, isImplicitId, idCafInfo )
+import DataCon         ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks )
 import IdInfo          -- Lots
 import CoreSyn         ( CoreRule(..), IdCoreRule )
 import CoreFVs         ( ruleLhsFreeNames )
@@ -53,9 +53,10 @@ import TyCon         ( DataConDetails(..), tyConTyVars, tyConDataCons, tyConTheta,
                          isFunTyCon, isPrimTyCon, isNewTyCon, isClassTyCon, 
                          isSynTyCon, isAlgTyCon, isForeignTyCon,
                          getSynTyConDefn, tyConGenInfo, tyConDataConDetails, tyConArity )
-import Class           ( classExtraBigSig, classTyCon, DefMeth(..) )
+import Class           ( classExtraBigSig, classTyCon )
 import FieldLabel      ( fieldLabelType )
-import TcType          ( tcSplitForAllTys, tcFunResultTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead )
+import TcType          ( tcSplitForAllTys, tcFunResultTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead,
+                         mkSigmaTy, mkFunTys, mkTyConApp, mkTyVarTys )
 import SrcLoc          ( noSrcLoc )
 import Module          ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule,
                          ModLocation(..), mkSysModuleNameFS, 
@@ -63,13 +64,15 @@ import Module               ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule,
                          extendModuleEnv_C, moduleEnvElts 
                        )
 import Outputable
+import DriverUtil      ( createDirectoryHierarchy, directoryOf )
 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 +89,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,
@@ -163,9 +169,9 @@ mkIface hsc_env location maybe_old_iface
        ; let (final_iface, maybe_diffs) = _scc_ "versioninfo" addVersionInfo maybe_old_iface iface_w_decls
 
                -- Write the interface file, if necessary
-       ; when (must_write_hi_file maybe_diffs)
-               (writeBinIface hi_file_path final_iface)
---             (writeIface hi_file_path final_iface)
+       ; when (must_write_hi_file maybe_diffs) $ do
+               createDirectoryHierarchy (directoryOf hi_file_path)
+               writeBinIface hi_file_path final_iface
 
                -- Debug printing
        ; write_diffs dflags final_iface maybe_diffs
@@ -220,6 +226,8 @@ we miss them out of the accumulating parameter here.
 
 \begin{code}
 ifaceTyThing_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
+-- Don't put implicit things into the result
+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,7 +254,7 @@ 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
                -- Be careful when splitting the type, because of things
                -- like         class Foo a where
@@ -255,10 +263,6 @@ ifaceTyThing (AClass clas) = cls_decl
                --                op :: (Ord a) => a -> a
          (sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id)
          op_ty                = tcFunResultTy rho_ty
-         def_meth' = case def_meth of
-                        NoDefMeth  -> NoDefMeth
-                        GenDefMeth -> GenDefMeth
-                        DefMeth id -> DefMeth (getName id)
 
 ifaceTyThing (ATyCon tycon) = ty_decl
   where
@@ -308,7 +312,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
@@ -333,13 +337,12 @@ ifaceTyThing (AnId id) = iface_sig
     iface_sig = IfaceSig { tcdName   = getName id, 
                           tcdType   = toHsType id_type,
                           tcdIdInfo = hs_idinfo,
-                          tcdLoc    =  noSrcLoc }
+                          tcdLoc    = noSrcLoc }
 
     id_type = idType id
     id_info = idInfo id
-    cg_info = idCgInfo id
     arity_info = arityInfo id_info
-    caf_info   = cgCafInfo cg_info
+    caf_info   = idCafInfo id
 
     hs_idinfo | opt_OmitInterfacePragmas
              = []
@@ -379,6 +382,23 @@ ifaceTyThing (AnId id) = iface_sig
     unfold_hsinfo |  neverUnfold unfold_info 
                  || has_worker = Nothing
                  | otherwise   = Just (HsUnfold inline_prag (toUfExpr rhs))
+
+
+ifaceTyThing (ADataCon dc)
+       -- This case only happens in the call to ifaceThing in InteractiveUI
+       -- Otherwise DataCons are filtered out in ifaceThing_acc
+ = IfaceSig { tcdName   = getName dc, 
+             tcdType   = toHsType full_ty,
+             tcdIdInfo = [],
+             tcdLoc    = noSrcLoc }
+ where
+    (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc
+
+       -- The "stupid context" isn't part of the wrapper-Id type
+       -- (for better or worse -- see note in DataCon.lhs), so we
+       -- have to make it up here
+    full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta) 
+                       (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs)))
 \end{code}
 
 \begin{code}
@@ -491,6 +511,7 @@ mkUsageInfo hsc_env eps
   where
     usages = catMaybes [ mkUsage mod_name 
                       | (mod_name,_) <- moduleEnvElts dep_mods]
+       -- ToDo: do we need to sort into canonical order?
 
     hpt = hsc_HPT hsc_env
     pit = eps_PIT eps
@@ -550,6 +571,7 @@ mkUsageInfo hsc_env eps
         ent_vers = [(n, lookupVersion version_env n) 
                   | n <- sortLt lt_occ used_names ]
         lt_occ n1 n2 = nameOccName n1 < nameOccName n2
+       -- ToDo: is '<' on OccNames the right thing; may differ between runs?
 \end{code}
 
 \begin{code}