[project @ 2000-10-26 07:19:52 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 c911132..1172df3 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -14,13 +14,16 @@ import HsSyn
 import HsCore          ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr )
 import HsTypes         ( toHsTyVars )
 import BasicTypes      ( Fixity(..), NewOrData(..),
-                         Version, bumpVersion, isLoopBreaker
+                         Version, initialVersion, bumpVersion, isLoopBreaker
                        )
 import RnMonad
 import RnHsSyn         ( RenamedInstDecl, RenamedTyClDecl )
 import TcHsSyn         ( TypecheckedRuleDecl )
 import HscTypes                ( VersionInfo(..), IfaceDecls(..), ModIface(..), ModDetails(..),
-                         TyThing(..), DFunId, TypeEnv, isTyClThing
+                         TyThing(..), DFunId, TypeEnv, isTyClThing, Avails,
+                         WhatsImported(..), GenAvailInfo(..), 
+                         ImportVersion, AvailInfo, Deprecations(..), 
+                         Finder, ModuleLocation(..)
                        )
 
 import CmdLineOpts
@@ -42,6 +45,7 @@ import Name           ( isLocallyDefined, getName,
                          plusNameEnv, lookupNameEnv, emptyNameEnv, mkNameEnv,
                          extendNameEnv, lookupNameEnv_NF, nameEnvElts
                        )
+import OccName         ( pprOccName )
 import TyCon           ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
                          tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
                        )
@@ -50,8 +54,10 @@ import FieldLabel    ( fieldLabelType )
 import Type            ( splitSigmaTy, tidyTopType, deNoteType )
 import SrcLoc          ( noSrcLoc )
 import Outputable
+import Module          ( ModuleName, moduleName )
 
 import List            ( partition )
+import IO              ( IOMode(..), openFile, hClose )
 \end{code}
 
 
@@ -597,14 +603,24 @@ diffDecls old_vers old_fixities new_fixities old new
 %************************************************************************
 
 \begin{code}
-writeIface :: Finder -> ModIface -> IO ()
-writeIface finder mod_iface
-  = do { let filename = error "... find the right file..."
+writeIface :: Finder -> Maybe ModIface -> IO ()
+writeIface finder Nothing
+  = return ()
+
+writeIface finder (Just mod_iface)
+  = do { maybe_found <- finder mod_name ;
+       ; case maybe_found of {
+           Nothing -> printErrs (text "Can't write interface file for" <+> ppr mod_name) ;
+           Just (_, locn) ->
+
+    do { let filename = hi_file locn 
        ; if_hdl <- openFile filename WriteMode
        ; printForIface if_hdl (pprIface mod_iface)
        ; hClose if_hdl
-       }
-
+       }}}
+  where
+    mod_name = moduleName (mi_module mod_iface)
+        
 pprIface iface
  = vcat [ ptext SLIT("__interface")
                <+> doubleQuotes (ptext opt_InPackage)
@@ -614,7 +630,7 @@ pprIface iface
                <+> int opt_HiVersion
                <+> ptext SLIT("where")
 
-       , pprExports (mi_exports iface)
+       , vcat (map pprExport (mi_exports iface))
        , vcat (map pprUsage (mi_usages iface))
 
        , pprIfaceDecls (vers_decls version_info) 
@@ -624,7 +640,7 @@ pprIface iface
        , pprDeprecs (mi_deprecs iface)
        ]
   where
-    version_info = mi_version mod_iface
+    version_info = mi_version iface
     exp_vers     = vers_exports version_info
     rule_vers   = vers_rules version_info
 
@@ -640,26 +656,29 @@ When printing export lists, we print like this:
 \begin{code}
 pprExport :: (ModuleName, Avails) -> SDoc
 pprExport (mod, items)
- = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
+ = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi
   where
-    pp_avail :: RdrAvailInfo -> SDoc
-    pp_avail (Avail name)      = pprOccName name
+    ppr_name :: Name -> SDoc   -- Print the occurrence name only
+    ppr_name n = ppr (nameOccName n)
+
+    pp_avail :: AvailInfo -> SDoc
+    pp_avail (Avail name)      = ppr_name name
     pp_avail (AvailTC name []) = empty
-    pp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
+    pp_avail (AvailTC name ns) = hcat [ppr_name name, bang, pp_export ns']
                                where
                                  bang | name `elem` ns = empty
                                       | otherwise      = char '|'
                                  ns' = filter (/= name) ns
     
     pp_export []    = empty
-    pp_export names = braces (hsep (map pprOccName names))
+    pp_export names = braces (hsep (map ppr_name names))
 \end{code}
 
 
 \begin{code}
 pprUsage :: ImportVersion Name -> SDoc
 pprUsage (m, has_orphans, is_boot, whats_imported)
-  = hsep [ptext SLIT("import"), pprModuleName m, 
+  = hsep [ptext SLIT("import"), ppr m, 
          pp_orphan, pp_boot,
          pp_versions whats_imported
     ] <> semi
@@ -696,20 +715,24 @@ pprIfaceDecls version_map fixity_map decls
                   Just v  -> int v
 
        -- Print fixities relevant to the decl
-    ppr_fixes d = vcat (map ppr_fix (fixities d))
-    fixities d  = [ ppr fix <+> ppr n <> semi
-                 | n <- tyClDeclNames d, 
-                   [Just fix] <- lookupNameEnv fixity_map n
-                 ]
+    ppr_fixes d = vcat [ ppr fix <+> ppr n <> semi
+                      | (n,_) <- tyClDeclNames d, 
+                        Just fix <- [lookupNameEnv fixity_map n]
+                      ]
 \end{code}
 
 \begin{code}
 pprRules []    = empty
 pprRules rules = hsep [ptext SLIT("{-## __R"), vcat (map ppr rules), ptext SLIT("##-}")]
 
-pprDeprecs []   = empty
-pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
-               where
-                 guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi 
-                             | Deprecation ie txt _ <- deps ]
+pprDeprecs NoDeprecs = empty
+pprDeprecs deprecs   = ptext SLIT("{-## __D") <+> guts <+> ptext SLIT("##-}")
+                    where
+                      guts = case deprecs of
+                               DeprecAll txt  -> ptext txt
+                               DeprecSome env -> pp_deprecs env
+
+pp_deprecs env = vcat (punctuate semi (map pp_deprec (nameEnvElts env)))
+              where
+                pp_deprec (name, txt) = pprOccName (nameOccName name) <+> ptext txt
 \end{code}