[project @ 2001-10-15 15:05:17 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 9ba3a2f..4f24901 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -8,7 +8,7 @@
 module MkIface ( 
        mkFinalIface,
        pprModDetails, pprIface, pprUsage,
-       ifaceTyCls,
+       ifaceTyThing,
   ) where
 
 #include "HsVersions.h"
@@ -17,9 +17,10 @@ import HsSyn
 import HsCore          ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr )
 import HsTypes         ( toHsTyVars )
 import TysPrim         ( alphaTyVars )
-import BasicTypes      ( Fixity(..), NewOrData(..),
-                         Version, initialVersion, bumpVersion, 
+import BasicTypes      ( Fixity(..), NewOrData(..), Activation(..),
+                         Version, initialVersion, bumpVersion 
                        )
+import NewDemand       ( isTopSig )
 import RnMonad
 import RnHsSyn         ( RenamedInstDecl, RenamedTyClDecl )
 import HscTypes                ( VersionInfo(..), ModIface(..), ModDetails(..),
@@ -117,7 +118,7 @@ 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 ifaceTyCls_acc [] (md_types 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
 
@@ -143,18 +144,18 @@ Implicit Ids and class tycons aren't included in interface files, so
 we miss them out of the accumulating parameter here.
 
 \begin{code}
-ifaceTyCls_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
-ifaceTyCls_acc (AnId   id) so_far | isImplicitId id = so_far
-ifaceTyCls_acc (ATyCon id) so_far | isClassTyCon id = so_far
-ifaceTyCls_acc other so_far = ifaceTyCls other : so_far
+ifaceTyThing_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
+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
 \end{code}
 
 Convert *any* TyThing into a RenamedTyClDecl.  Used both for
 generating interface files and for the ':info' command in GHCi.
 
 \begin{code}
-ifaceTyCls :: TyThing -> RenamedTyClDecl
-ifaceTyCls (AClass clas) = cls_decl
+ifaceTyThing :: TyThing -> RenamedTyClDecl
+ifaceTyThing (AClass clas) = cls_decl
   where
     cls_decl = ClassDecl { tcdCtxt     = toHsContext sc_theta,
                           tcdName      = getName clas,
@@ -181,7 +182,7 @@ ifaceTyCls (AClass clas) = cls_decl
                         GenDefMeth -> GenDefMeth
                         DefMeth id -> DefMeth (getName id)
 
-ifaceTyCls (ATyCon tycon) = ty_decl
+ifaceTyThing (ATyCon tycon) = ty_decl
   where
     ty_decl | isSynTyCon tycon
            = TySynonym { tcdName   = getName tycon,
@@ -217,7 +218,7 @@ ifaceTyCls (ATyCon tycon) = ty_decl
                        tcdSysNames  = [],
                        tcdLoc       = noSrcLoc }
 
-           | otherwise = pprPanic "ifaceTyCls" (ppr tycon)
+           | otherwise = pprPanic "ifaceTyThing" (ppr tycon)
 
     tyvars      = tyConTyVars tycon
     (_, syn_ty) = getSynTyConDefn tycon
@@ -245,7 +246,7 @@ ifaceTyCls (ATyCon tycon) = ty_decl
     mk_field strict_mark field_label
        = ([getName field_label], BangType strict_mark (toHsType (fieldLabelType field_label)))
 
-ifaceTyCls (AnId id) = iface_sig
+ifaceTyThing (AnId id) = iface_sig
   where
     iface_sig = IfaceSig { tcdName   = getName id, 
                           tcdType   = toHsType id_type,
@@ -272,9 +273,10 @@ ifaceTyCls (AnId id) = iface_sig
                   otherwise -> []
 
     ------------  Strictness  --------------
+       -- No point in explicitly exporting TopSig
     strict_hsinfo = case newStrictnessInfo id_info of
-                       Nothing  -> []
-                       Just sig -> [HsStrictness sig]
+                       Just sig | not (isTopSig sig) -> [HsStrictness sig]
+                       other                         -> []
 
     ------------  Worker  --------------
     work_info   = workerInfo id_info
@@ -313,12 +315,12 @@ ifaceInstance dfun_id
 ifaceRule (id, BuiltinRule _ _)
   = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
 
-ifaceRule (id, Rule name bndrs args rhs)
-  = IfaceRule name (map toUfBndr bndrs) (getName id)
+ifaceRule (id, Rule name act bndrs args rhs)
+  = IfaceRule name act (map toUfBndr bndrs) (getName id)
              (map toUfExpr args) (toUfExpr rhs) noSrcLoc
 
 bogusIfaceRule id
-  = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
+  = IfaceRule SLIT("bogus") NeverActive [] (getName id) [] (UfVar (getName id)) noSrcLoc
 \end{code}