[project @ 2001-08-31 13:51:45 by sewardj]

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

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 85b7a92..98a160f 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -7,7 +7,8 @@
 \begin{code}
 module MkIface ( 
        mkFinalIface,
-       pprModDetails, pprIface, pprUsage
+       pprModDetails, pprIface, pprUsage,
+       ifaceTyCls,
   ) where
 
 #include "HsVersions.h"
@@ -15,20 +16,20 @@ module MkIface (
 import HsSyn
 import HsCore          ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr )
 import HsTypes         ( toHsTyVars )
+import TysPrim         ( alphaTyVars )
 import BasicTypes      ( Fixity(..), NewOrData(..),
                          Version, initialVersion, bumpVersion, 
                        )
 import RnMonad
 import RnHsSyn         ( RenamedInstDecl, RenamedTyClDecl )
 import HscTypes                ( VersionInfo(..), ModIface(..), ModDetails(..),
-                         ModuleLocation(..), 
+                         ModuleLocation(..), GhciMode(..),
                          IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
                          TyThing(..), DFunId, Avails,
                          WhatsImported(..), GenAvailInfo(..), 
                          ImportVersion, AvailInfo, Deprecations(..),
                          lookupVersion,
                        )
-import CmStaticInfo    ( GhciMode(..) )
 
 import CmdLineOpts
 import Id              ( idType, idInfo, isImplicitId, idCgInfo,
@@ -45,13 +46,14 @@ import Name         ( getName, nameModule, toRdrName, isGlobalName,
 import NameEnv
 import NameSet
 import OccName         ( pprOccName )
-import TyCon           ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds,
-                         tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, 
-                         isClassTyCon, isForeignTyCon
+import TyCon           ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, 
+                         isAlgTyCon, tyConGenIds, tyConTheta, tyConTyVars,
+                         tyConDataCons, tyConFamilySize, isPrimTyCon,
+                         isClassTyCon, isForeignTyCon, tyConArity
                        )
 import Class           ( classExtraBigSig, classTyCon, DefMeth(..) )
 import FieldLabel      ( fieldLabelType )
-import Type            ( splitSigmaTy, tidyTopType, deNoteType, namesOfDFunHead )
+import TcType          ( tcSplitSigmaTy, tidyTopType, deNoteType, namesOfDFunHead )
 import SrcLoc          ( noSrcLoc )
 import Outputable
 import Module          ( ModuleName )
@@ -115,7 +117,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 [] (md_types new_details)
+     ty_cls_dcls  = foldNameEnv ifaceTyCls_acc [] (md_types new_details)
      rule_dcls    = map ifaceRule (md_rules new_details)
      orphan_mod   = isOrphanModule (mi_module new_iface) new_details
 
@@ -137,10 +139,22 @@ isOrphanModule this_mod (ModDetails {md_insts = insts, md_rules = rules})
     no_locals names     = isEmptyNameSet (filterNameSet (nameIsLocalOrFrom this_mod) names)
 \end{code}
 
+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
+\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] -> [RenamedTyClDecl]
-ifaceTyCls (AClass clas) so_far
-  = cls_decl : so_far
+ifaceTyCls :: TyThing -> RenamedTyClDecl
+ifaceTyCls (AClass clas) = cls_decl
   where
     cls_decl = ClassDecl { tcdCtxt     = toHsContext sc_theta,
                           tcdName      = getName clas,
@@ -161,15 +175,13 @@ ifaceTyCls (AClass clas) so_far
        = ASSERT(sel_tyvars == clas_tyvars)
          ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc
        where
-         (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
+         (sel_tyvars, _, op_ty) = tcSplitSigmaTy (idType sel_id)
          def_meth' = case def_meth of
                         NoDefMeth  -> NoDefMeth
                         GenDefMeth -> GenDefMeth
                         DefMeth id -> DefMeth (getName id)
 
-ifaceTyCls (ATyCon tycon) so_far
-  | isClassTyCon tycon = so_far
-  | otherwise         = ty_decl : so_far
+ifaceTyCls (ATyCon tycon) = ty_decl
   where
     ty_decl | isSynTyCon tycon
            = TySynonym { tcdName   = getName tycon,
@@ -193,6 +205,18 @@ ifaceTyCls (ATyCon tycon) so_far
                            tcdFoType = DNType, -- The only case at present
                            tcdLoc    = noSrcLoc }
 
+           | isPrimTyCon tycon
+               -- needed in GHCi for ':info Int#', for example
+           = TyData {  tcdND     = DataType,
+                       tcdCtxt   = [],
+                       tcdName   = getName tycon,
+                       tcdTyVars = toHsTyVars (take (tyConArity tycon) alphaTyVars),
+                       tcdCons   = [],
+                       tcdNCons  = 0,
+                       tcdDerivs = Nothing,
+                       tcdSysNames  = [],
+                       tcdLoc       = noSrcLoc }
+
            | otherwise = pprPanic "ifaceTyCls" (ppr tycon)
 
     tyvars      = tyConTyVars tycon
@@ -221,9 +245,7 @@ ifaceTyCls (ATyCon tycon) so_far
     mk_field strict_mark field_label
        = ([getName field_label], BangType strict_mark (toHsType (fieldLabelType field_label)))
 
-ifaceTyCls (AnId id) so_far
-  | isImplicitId id = so_far
-  | otherwise      = iface_sig : so_far
+ifaceTyCls (AnId id) = iface_sig
   where
     iface_sig = IfaceSig { tcdName   = getName id, 
                           tcdType   = toHsType id_type,
@@ -237,7 +259,7 @@ ifaceTyCls (AnId id) so_far
     caf_info   = cgCafInfo cg_info
 
     hs_idinfo | opt_OmitInterfacePragmas = []
-             | otherwise                = arity_hsinfo  ++ caf_hsinfo  ++ cpr_hsinfo ++ 
+             | otherwise                = arity_hsinfo  ++ caf_hsinfo  ++ 
                                           strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
 
     ------------  Arity  --------------
@@ -249,15 +271,10 @@ ifaceTyCls (AnId id) so_far
                   NoCafRefs -> [HsNoCafRefs]
                   otherwise -> []
 
-    ------------ CPR Info --------------
-    cpr_hsinfo = case cprInfo id_info of
-                  ReturnsCPR -> [HsCprInfo]
-                  NoCPRInfo  -> []
-
     ------------  Strictness  --------------
-    strict_hsinfo = case strictnessInfo id_info of
-                       NoStrictnessInfo -> []
-                       info             -> [HsStrictness info]
+    strict_hsinfo = case newStrictnessInfo id_info of
+                       Nothing  -> []
+                       Just sig -> [HsStrictness sig]
 
     ------------  Worker  --------------
     work_info   = workerInfo id_info