[project @ 2000-10-16 08:24:18 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 678aaec..1d709ef 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -8,15 +8,14 @@ module MkIface ( writeIface  ) where
 
 #include "HsVersions.h"
 
-import IO              ( Handle, hPutStr, openFile, 
-                         hClose, hPutStrLn, IOMode(..) )
+import IO              ( openFile, hClose, IOMode(..) )
 
 import HsSyn
 import HsCore          ( HsIdInfo(..), toUfExpr )
-import RdrHsSyn                ( RdrNameRuleDecl )
+import RdrHsSyn                ( RdrNameRuleDecl, mkTyData )
 import HsPragmas       ( DataPragmas(..), ClassPragmas(..) )
 import HsTypes         ( toHsTyVars )
-import BasicTypes      ( Fixity(..), FixityDirection(..), NewOrData(..),
+import BasicTypes      ( Fixity(..), NewOrData(..),
                          Version, bumpVersion, initialVersion, isLoopBreaker
                        )
 import RnMonad
@@ -27,21 +26,21 @@ import CmdLineOpts
 import Id              ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
                          idSpecialisation
                        )
-import Var             ( isId )
+import Var             ( isId, varName )
 import VarSet
 import DataCon         ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
-import IdInfo          ( IdInfo, StrictnessInfo(..), ArityInfo(..), InlinePragInfo(..), 
+import IdInfo          ( IdInfo, StrictnessInfo(..), ArityInfo(..), 
                          CprInfo(..), CafInfo(..),
                          inlinePragInfo, arityInfo, arityLowerBound,
                          strictnessInfo, isBottomingStrictness,
                          cafInfo, specInfo, cprInfo, 
                          occInfo, isNeverInlinePrag,
-                         workerExists, workerInfo, WorkerInfo(..)
+                         workerInfo, WorkerInfo(..)
                        )
 import CoreSyn         ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
 import CoreFVs         ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
 import CoreUnfold      ( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
-import Module          ( moduleString, pprModule, pprModuleName, moduleUserString )
+import Module          ( pprModuleName, moduleUserString )
 import Name            ( isLocallyDefined, isWiredInName, toRdrName, nameModule,
                          Name, NamedThing(..)
                        )
@@ -49,20 +48,17 @@ import OccName              ( OccName, pprOccName )
 import TyCon           ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
                          tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
                        )
-import Class           ( Class, classExtraBigSig )
-import FieldLabel      ( fieldLabelName, fieldLabelType )
+import Class           ( classExtraBigSig, DefMeth(..) )
+import FieldLabel      ( fieldLabelType )
 import Type            ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType,
-                         deNoteType, classesToPreds,
-                         Type, ThetaType, PredType(..), ClassContext
+                         deNoteType, classesToPreds
                        )
 
-import PprType
-import Rules           ( pprProtoCoreRule, ProtoCoreRule(..) )
+import Rules           ( ProtoCoreRule(..) )
 
-import Bag             ( bagToList, isEmptyBag )
-import Maybes          ( catMaybes, maybeToBool )
+import Bag             ( bagToList )
 import UniqFM          ( lookupUFM, listToUFM )
-import Util            ( sortLt, mapAccumL )
+import Util            ( sortLt )
 import SrcLoc          ( noSrcLoc )
 import Bag
 import Outputable
@@ -109,8 +105,8 @@ writeIface this_mod old_iface new_iface
          Just final_iface ->
 
        do  let mod_vers_unchanged = case old_iface of
-                                  Just iface -> pi_vers iface == pi_vers final_iface
-                                  Nothing -> False
+                                     Just iface -> pi_vers iface == pi_vers final_iface
+                                     Nothing -> False
           when (mod_vers_unchanged && opt_D_dump_rn_trace) $
                putStrLn "Module version unchanged, but usages differ; hence need new hi file"
 
@@ -153,7 +149,7 @@ checkIface (Just iface) new_iface
 
   | otherwise          -- Add updated version numbers
   = do { dumpIfSet opt_D_dump_hi_diffs "Interface file changes" pp_diffs ;
-        return (Just new_iface )}
+        return (Just final_iface )}
        
   where
     final_iface = new_iface { pi_vers = new_mod_vers,
@@ -394,8 +390,7 @@ ifaceInstances inst_infos
                --      instance Foo Tibble where ...
                -- and this instance decl wouldn't get imported into a module
                -- that mentioned T but not Tibble.
-           forall_ty     = mkSigmaTy tvs (classesToPreds theta)
-                                     (deNoteType (mkDictTy clas tys))
+           forall_ty     = mkSigmaTy tvs theta (deNoteType (mkDictTy clas tys))
            tidy_ty = tidyTopType forall_ty
        in                       
        InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (toRdrName dfun_id)) noSrcLoc 
@@ -413,7 +408,7 @@ ifaceTyCon tycon
 
 ifaceTyCon tycon
   | isAlgTyCon tycon
-  = TyClD (TyData new_or_data (toHsContext (tyConTheta tycon))
+  = TyClD (mkTyData new_or_data (toHsContext (tyConTheta tycon))
                  (toRdrName tycon)
                  (toHsTyVars tyvars)
                  (map ifaceConDecl (tyConDataCons tycon))
@@ -458,24 +453,28 @@ ifaceClass clas
                     (toHsFDs clas_fds)
                     (map toClassOpSig op_stuff)
                     EmptyMonoBinds NoClassPragmas
-                    bogus bogus bogus [] noSrcLoc
+                    [] noSrcLoc
     )
   where
      bogus = error "ifaceClass"
      (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
 
-     toClassOpSig (sel_id, dm_id, explicit_dm)
-       = ASSERT( sel_tyvars == clas_tyvars)
-         ClassOpSig (toRdrName sel_id) (Just (bogus, explicit_dm)) (toHsType op_ty) noSrcLoc
+     toClassOpSig (sel_id, def_meth) = 
+       ASSERT(sel_tyvars == clas_tyvars)
+         ClassOpSig (toRdrName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
        where
          (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
+         def_meth' = case def_meth of
+                        NoDefMeth  -> NoDefMeth
+                        GenDefMeth -> GenDefMeth
+                        DefMeth id -> DefMeth (toRdrName id)
 \end{code}
 
 
 %************************************************************************
 %*                                                                     *
 \subsection{Value bindings}
-%*                                                                     *
+%*                                                                     * 
 %************************************************************************
 
 \begin{code}
@@ -669,14 +668,6 @@ ifaceId get_idinfo is_rec id rhs
 
     find_fvs expr = exprSomeFreeVars interestingId expr
 
-    ------------ Sanity checking --------------
-       -- The arity of a wrapper function should match its strictness,
-       -- or else an importing module will get very confused indeed.
-    arity_matches_strictness 
-       = case work_info of
-            HasWorker _ wrap_arity -> wrap_arity == arityLowerBound arity_info
-            other                  -> True
-    
 interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
 \end{code}