[project @ 2001-07-03 11:14:33 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 9ed8665..508ec26 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -1,6 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 %
+
 \section[MkIface]{Print an interface for a module}
 
 \begin{code}
@@ -20,20 +21,19 @@ import BasicTypes   ( Fixity(..), NewOrData(..),
 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,
                          isLocalId, idName,
                        )
-import DataCon         ( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
+import DataCon         ( dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
 import IdInfo          -- Lots
 import CoreSyn         ( CoreRule(..) )
 import CoreFVs         ( ruleLhsFreeNames )
@@ -45,15 +45,16 @@ import NameEnv
 import NameSet
 import OccName         ( pprOccName )
 import TyCon           ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds,
-                         tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon
+                         tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, 
+                         isClassTyCon, isForeignTyCon
                        )
 import Class           ( classExtraBigSig, classTyCon, DefMeth(..) )
 import FieldLabel      ( fieldLabelType )
-import Type            ( splitSigmaTy, tidyTopType, deNoteType, namesOfType )
+import TcType          ( tcSplitSigmaTy, tidyTopType, deNoteType, namesOfDFunHead )
 import SrcLoc          ( noSrcLoc )
 import Outputable
 import Module          ( ModuleName )
-import Util            ( sortLt, unJust )
+import Util            ( sortLt )
 import ErrUtils                ( dumpIfSet_dyn )
 
 import Monad           ( when )
@@ -110,7 +111,7 @@ mkFinalIface ghci_mode dflags location
                --     so there's no need to write a new interface file.  But even if 
                --     the usages have changed, the module version may not have.
 
-     hi_file_path = unJust "mkFinalIface" (ml_hi_file 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)
@@ -130,15 +131,9 @@ write_diffs dflags new_iface (Just sdoc_diffs)
 isOrphanModule this_mod (ModDetails {md_insts = insts, md_rules = rules})
   = any orphan_inst insts || any orphan_rule rules
   where
-    orphan_inst dfun_id = no_locals (namesOfType (dfun_head_type dfun_id))
+    orphan_inst dfun_id = no_locals (namesOfDFunHead (idType dfun_id))
     orphan_rule rule    = no_locals (ruleLhsFreeNames rule)
     no_locals names     = isEmptyNameSet (filterNameSet (nameIsLocalOrFrom this_mod) names)
-    dfun_head_type dfun        = case splitSigmaTy (idType dfun) of
-                               (_,_,head_ty) -> head_ty
-       -- The 'dfun_head_type' is because of
-       --      instance Foo a => Baz T where ...
-       -- The decl is an orphan if Baz and T are both not locally defined,
-       --      even if Foo *is* locally defined
 \end{code}
 
 \begin{code}
@@ -165,7 +160,7 @@ 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
@@ -192,6 +187,11 @@ ifaceTyCls (ATyCon tycon) so_far
                        tcdSysNames  = map getName (tyConGenIds tycon),
                        tcdLoc       = noSrcLoc }
 
+           | isForeignTyCon tycon
+           = ForeignType { tcdName   = getName tycon,
+                           tcdFoType = DNType, -- The only case at present
+                           tcdLoc    = noSrcLoc }
+
            | otherwise = pprPanic "ifaceTyCls" (ppr tycon)
 
     tyvars      = tyConTyVars tycon
@@ -207,20 +207,18 @@ ifaceTyCls (ATyCon tycon) so_far
        where
          (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
           field_labels   = dataConFieldLabels data_con
-          strict_marks   = dataConStrictMarks data_con
+          strict_marks   = drop (length ex_theta) (dataConStrictMarks data_con)
+                               -- The 'drop' is because dataConStrictMarks
+                               -- includes the existential dictionaries
          details | null field_labels
                  = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
-                   VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
+                   VanillaCon (zipWith BangType strict_marks (map toHsType arg_tys))
 
                  | otherwise
                  = RecCon (zipWith mk_field strict_marks field_labels)
 
-    mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
-    mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
-    mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)
-
     mk_field strict_mark field_label
-       = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
+       = ([getName field_label], BangType strict_mark (toHsType (fieldLabelType field_label)))
 
 ifaceTyCls (AnId id) so_far
   | isImplicitId id = so_far