[project @ 2002-01-03 17:09:13 by simonmar]

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

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 5fa1360..4eed2e6 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -59,11 +59,11 @@ import TcType               ( tcSplitSigmaTy, tidyTopType, deNoteType, namesOfDFunHead )
 import SrcLoc          ( noSrcLoc )
 import Outputable
 import Module          ( ModuleName )
-import Util            ( sortLt )
+import Util            ( sortLt, dropList )
 import ErrUtils                ( dumpIfSet_dyn )
 
-import Monad           ( when, mplus )
-import Maybe           ( maybeToList )
+import Monad           ( when )
+import Maybe           ( catMaybes )
 import IO              ( IOMode(..), openFile, hClose )
 \end{code}
 
@@ -89,15 +89,18 @@ mkFinalIface :: GhciMode
 --     a) completes the interface
 --     b) writes it out to a file if necessary
 
-mkFinalIface ghci_mode dflags location 
-            maybe_old_iface new_iface new_details
+mkFinalIface ghci_mode dflags location maybe_old_iface 
+       new_iface@ModIface{ mi_module=mod }
+       new_details@ModDetails{ md_insts=insts, 
+                               md_rules=rules,
+                               md_types=types }
   = do { 
                -- Add the new declarations, and the is-orphan flag
          let iface_w_decls = new_iface { mi_decls = new_decls,
                                          mi_orphan = orphan_mod }
 
                -- Add version information
-       ; let (final_iface, maybe_diffs) = addVersionInfo maybe_old_iface iface_w_decls
+       ; 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)
@@ -106,7 +109,8 @@ mkFinalIface ghci_mode dflags location
                -- Debug printing
        ; write_diffs dflags final_iface maybe_diffs
 
-       ; return final_iface }
+       ; orphan_mod `seq`
+         return final_iface }
 
   where
      must_write_hi_file Nothing       = False
@@ -119,10 +123,10 @@ mkFinalIface ghci_mode dflags location
 
      hi_file_path = ml_hi_file location
      new_decls    = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
-     inst_dcls    = map ifaceInstance (md_insts new_details)
-     ty_cls_dcls  = foldNameEnv ifaceTyThing_acc [] (md_types new_details)
-     rule_dcls    = map ifaceRule (md_rules new_details)
-     orphan_mod   = isOrphanModule (mi_module new_iface) new_details
+     inst_dcls    = map ifaceInstance insts
+     ty_cls_dcls  = foldNameEnv ifaceTyThing_acc [] types
+     rule_dcls    = map ifaceRule rules
+     orphan_mod   = isOrphanModule mod new_details
 
 write_diffs :: DynFlags -> ModIface -> Maybe SDoc -> IO ()
 write_diffs dflags new_iface Nothing
@@ -238,7 +242,7 @@ ifaceTyThing (ATyCon tycon) = ty_decl
        where
          (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
           field_labels   = dataConFieldLabels data_con
-          strict_marks   = drop (length ex_theta) (dataConStrictMarks data_con)
+          strict_marks   = dropList ex_theta (dataConStrictMarks data_con)
                                -- The 'drop' is because dataConStrictMarks
                                -- includes the existential dictionaries
          details | null field_labels
@@ -264,13 +268,12 @@ ifaceTyThing (AnId id) = iface_sig
     arity_info = arityInfo id_info
     caf_info   = cgCafInfo cg_info
 
-    hs_idinfo | opt_OmitInterfacePragmas = []
-             | otherwise                = maybeToList $
-                                                  arity_hsinfo  `mplus`
-                                                  caf_hsinfo    `mplus`
-                                                  strict_hsinfo `mplus`
-                                                  wrkr_hsinfo   `mplus`
-                                                  unfold_hsinfo 
+    hs_idinfo | opt_OmitInterfacePragmas
+             = []
+             | otherwise
+             = catMaybes [arity_hsinfo,  caf_hsinfo,
+                          strict_hsinfo, wrkr_hsinfo,
+                          unfold_hsinfo] 
 
     ------------  Arity  --------------
     arity_hsinfo | arity_info == 0 = Nothing