X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FLoadIface.lhs;h=ba72c25d528ce559bd5ded296ad8e9e416261bae;hb=0cb269be72ffe42498c74d5be845eb27d8818423;hp=8c496f76efcbfe12d315629e66b90fc854fc28c7;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 8c496f7..ba72c25 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -1,28 +1,30 @@ -% + % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section{Dealing with interface files} \begin{code} module LoadIface ( - loadInterface, loadHomeInterface, loadWiredInHomeIface, + loadInterface, loadInterfaceForName, loadWiredInHomeIface, loadSrcInterface, loadSysInterface, loadOrphanModules, findAndReadIface, readIface, -- Used when reading the module's old interface loadDecls, ifaceStats, discardDeclPrags, - initExternalPackageState + initExternalPackageState, + + pprModIface, showIface -- Print the iface in Foo.hi ) where #include "HsVersions.h" import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRule, tcIfaceInst ) -import Packages ( PackageState(..), PackageIdH(..), isHomePackage ) -import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ), - isOneShot ) +import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceIdInfo(..) ) import IfaceEnv ( newGlobalBinder ) -import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), +import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..), + Deprecs(..), Dependencies(..), + emptyModIface, EpsStats(..), GenAvailInfo(..), addEpsInStats, ExternalPackageState(..), PackageTypeEnv, emptyTypeEnv, HscEnv(..), lookupIfaceByModule, emptyPackageIfaceTable, @@ -30,9 +32,11 @@ import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), implicitTyThings ) -import BasicTypes ( Version, Fixity(..), FixityDirection(..), - isMarkedStrict ) +import BasicTypes ( Version, initialVersion, + Fixity(..), FixityDirection(..), isMarkedStrict ) import TcRnMonad +import Type ( TyThing(..) ) +import Class ( classATs ) import PrelNames ( gHC_PRIM ) import PrelInfo ( ghcPrimExports ) @@ -43,21 +47,25 @@ import Name ( Name {-instance NamedThing-}, getOccName, nameModule, nameIsLocalOrFrom, isWiredInName ) import NameEnv import MkId ( seqId ) -import Module ( Module, ModLocation(ml_hi_file), emptyModuleEnv, - addBootSuffix_maybe, - extendModuleEnv, lookupModuleEnv, moduleString - ) -import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc, - mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc ) +import Module +import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, + mkClassDataConOcc, mkSuperDictSelOcc, + mkDataConWrapperOcc, mkDataConWorkerOcc, + mkNewTyCoOcc, mkInstTyTcOcc, mkInstTyCoOcc ) import SrcLoc ( importedSrcLoc ) import Maybes ( MaybeErr(..) ) -import FastString ( mkFastString ) import ErrUtils ( Message ) -import Finder ( findModule, findPackageModule, FindResult(..), cantFindError ) +import Finder ( findImportedModule, findExactModule, + FindResult(..), cannotFindInterface ) +import UniqFM +import StaticFlags ( opt_HiVersion ) import Outputable -import BinIface ( readBinIface ) +import BinIface ( readBinIface, v_IgnoreHiWay ) +import Binary ( getBinFileWithDict ) import Panic ( ghcError, tryMost, showException, GhcException(..) ) import List ( nub ) +import Maybe ( isJust ) +import DATA_IOREF ( writeIORef ) \end{code} @@ -70,22 +78,28 @@ import List ( nub ) %************************************************************************ \begin{code} -loadSrcInterface :: SDoc -> Module -> IsBootInterface -> RnM ModIface --- This is called for each 'import' declaration in the source code --- On a failure, fail in the monad with an error message - -loadSrcInterface doc mod want_boot - = do { mb_iface <- initIfaceTcRn $ - loadInterface doc mod (ImportByUser want_boot) - ; case mb_iface of - Failed err -> failWithTc (elaborate err) - Succeeded iface -> return iface - } - where - elaborate err = hang (ptext SLIT("Failed to load interface for") <+> - quotes (ppr mod) <> colon) 4 err - ---------------- +-- | Load the interface corresponding to an @import@ directive in +-- source code. On a failure, fail in the monad with an error message. +loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -> RnM ModIface +loadSrcInterface doc mod want_boot = do + -- We must first find which Module this import refers to. This involves + -- calling the Finder, which as a side effect will search the filesystem + -- and create a ModLocation. If successful, loadIface will read the + -- interface; it will call the Finder again, but the ModLocation will be + -- cached from the first search. + hsc_env <- getTopEnv + res <- ioToIOEnv $ findImportedModule hsc_env mod Nothing + case res of + Found _ mod -> do + mb_iface <- initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) + case mb_iface of + Failed err -> failWithTc err + Succeeded iface -> return iface + err -> + let dflags = hsc_dflags hsc_env in + failWithTc (cannotFindInterface dflags mod err) + +-- | Load interfaces for a collection of orphan modules. loadOrphanModules :: [Module] -> TcM () loadOrphanModules mods | null mods = returnM () @@ -98,9 +112,9 @@ loadOrphanModules mods load mod = loadSysInterface (mk_doc mod) mod mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module") ---------------- -loadHomeInterface :: SDoc -> Name -> TcRn ModIface -loadHomeInterface doc name +-- | Loads the interface for a given Name. +loadInterfaceForName :: SDoc -> Name -> TcRn ModIface +loadInterfaceForName doc name = do { #ifdef DEBUG -- Should not be called with a name from the module being compiled @@ -110,19 +124,17 @@ loadHomeInterface doc name initIfaceTcRn $ loadSysInterface doc (nameModule name) } ---------------- -loadWiredInHomeIface :: Name -> IfM lcl () --- A IfM function to load the home interface for a wired-in thing, +-- | An 'IfM' function to load the home interface for a wired-in thing, -- so that we're sure that we see its instance declarations and rules +loadWiredInHomeIface :: Name -> IfM lcl () loadWiredInHomeIface name = ASSERT( isWiredInName name ) - do { loadSysInterface doc (nameModule name); return () } + do loadSysInterface doc (nameModule name); return () where doc = ptext SLIT("Need home interface for wired-in thing") <+> ppr name ---------------- +-- | A wrapper for 'loadInterface' that throws an exception if it fails loadSysInterface :: SDoc -> Module -> IfM lcl ModIface --- A wrapper for loadInterface that Throws an exception if it fails loadSysInterface doc mod_name = do { mb_iface <- loadInterface doc mod_name ImportBySystem ; case mb_iface of @@ -142,7 +154,7 @@ loadSysInterface doc mod_name %********************************************************* \begin{code} -loadInterface :: SDoc -> Module -> WhereFrom +loadInterface :: SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr Message ModIface) -- If it can't find a suitable interface file, we @@ -161,7 +173,8 @@ loadInterface doc_str mod from ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from) -- Check whether we have the interface already - ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { + ; dflags <- getDOpts + ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of { Just iface -> returnM (Succeeded iface) ; -- Already loaded -- The (src_imp == mi_boot iface) test checks that the already-loaded @@ -173,7 +186,7 @@ loadInterface doc_str mod from ImportByUser usr_boot -> usr_boot ImportBySystem -> sys_boot - ; mb_dep = lookupModuleEnv (eps_is_boot eps) mod + ; mb_dep = lookupUFM (eps_is_boot eps) (moduleName mod) ; sys_boot = case mb_dep of Just (_, is_boot) -> is_boot Nothing -> False @@ -181,13 +194,11 @@ loadInterface doc_str mod from } -- based on the dependencies in directly-imported modules -- READ THE MODULE IN - ; let explicit | ImportByUser _ <- from = True - | otherwise = False - ; read_result <- findAndReadIface explicit doc_str mod hi_boot_file + ; read_result <- findAndReadIface doc_str mod hi_boot_file ; dflags <- getDOpts ; case read_result of { Failed err -> do - { let fake_iface = emptyModIface HomePackage mod + { let fake_iface = emptyModIface mod ; updateEps_ $ \eps -> eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } @@ -198,9 +209,10 @@ loadInterface doc_str mod from -- Found and parsed! Succeeded (iface, file_path) -- Sanity check: - | ImportBySystem <- from, -- system-importing... - isHomePackage (mi_package iface), -- ...a home-package module - Nothing <- mb_dep -- ...that we know nothing about + | ImportBySystem <- from, -- system-importing... + modulePackageId (mi_module iface) == thisPackage dflags, + -- a home-package module... + Nothing <- mb_dep -- that we know nothing about -> returnM (Failed (badDepMsg mod)) | otherwise -> @@ -260,6 +272,10 @@ badDepMsg mod -- each binder with the right package info in it -- All subsequent lookups, including crucially lookups during typechecking -- the declaration itself, will find the fully-glorious Name +-- +-- We handle ATs specially. They are not main declarations, but also not +-- implict things (in particular, adding them to `implicitTyThings' would mess +-- things up in the renaming/type checking of source programs). ----------------------------------------------------- addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv @@ -283,7 +299,8 @@ loadDecl ignore_prags mod (_version, decl) = do { -- Populate the name cache with final versions of all -- the names associated with the decl main_name <- mk_new_bndr mod Nothing (ifName decl) - ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl) + ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) + (ifaceDeclSubBndrs decl) -- Typecheck the thing, lazily -- NB. firstly, the laziness is there in case we never need the @@ -295,9 +312,12 @@ loadDecl ignore_prags mod (_version, decl) ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] lookup n = case lookupOccEnv mini_env (getOccName n) of Just thing -> thing - Nothing -> pprPanic "loadDecl" (ppr main_name <+> ppr n) + Nothing -> + pprPanic "loadDecl" (ppr main_name <+> + ppr n $$ ppr (stripped_decl)) - ; returnM ((main_name, thing) : [(n, lookup n) | n <- implicit_names]) } + ; returnM $ (main_name, thing) : [(n, lookup n) | n <- implicit_names] + } -- We build a list from the *known* names, with (lookup n) thunks -- as the TyThings. That way we can extend the PTE without poking the -- thunks @@ -312,7 +332,8 @@ loadDecl ignore_prags mod (_version, decl) -- imported name, to fix the module correctly in the cache mk_new_bndr mod mb_parent occ = newGlobalBinder mod occ mb_parent - (importedSrcLoc (moduleString mod)) + (importedSrcLoc (showSDoc (ppr (moduleName mod)))) + -- ToDo: qualify with the package name if necessary doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) @@ -332,34 +353,46 @@ ifaceDeclSubBndrs :: IfaceDecl -> [OccName] -- *Excludes* the 'main' name, but *includes* the implicitly-bound names -- Deeply revolting, because it has to predict what gets bound, -- especially the question of whether there's a wrapper for a datacon - -ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs }) - = [tc_occ, dc_occ, dcww_occ] ++ - [op | IfaceClassOp op _ _ <- sigs] ++ +-- +-- If you change this, make sure you change HscTypes.implicitTyThings in sync + +ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, + ifSigs = sigs, ifATs = ats }) + = co_occs ++ + [tc_occ, dc_occ, dcww_occ] ++ + [op | IfaceClassOp op _ _ <- sigs] ++ + [ifName at | at <- ats ] ++ [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] where n_ctxt = length sc_ctxt n_sigs = length sigs tc_occ = mkClassTyConOcc cls_occ dc_occ = mkClassDataConOcc cls_occ - dcww_occ | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker + co_occs | is_newtype = [mkNewTyCoOcc tc_occ] + | otherwise = [] + dcww_occ -- | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper is_newtype = n_sigs + n_ctxt == 1 -- Sigh -ifaceDeclSubBndrs (IfaceData {ifCons = IfAbstractTyCon}) +ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = [] -- Newtype -ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfVanillaCon { ifConOcc = con_occ, - ifConFields = fields})}) - = fields ++ [con_occ, mkDataConWrapperOcc con_occ] - -- Wrapper, no worker; see MkId.mkDataConIds - -ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons}) - = nub (concatMap fld_occs cons) -- Eliminate duplicate fields +ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, + ifCons = IfNewTyCon ( + IfCon { ifConOcc = con_occ, + ifConFields = fields + }), + ifFamInst = famInst}) + = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ] + ++ famInstCo famInst tc_occ + +ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, + ifCons = IfDataTyCon cons, + ifFamInst = famInst}) + = nub (concatMap ifConFields cons) -- Eliminate duplicate fields ++ concatMap dc_occs cons + ++ famInstCo famInst tc_occ where - fld_occs (IfVanillaCon { ifConFields = fields }) = fields - fld_occs (IfGadtCon {}) = [] dc_occs con_decl | has_wrapper = [con_occ, work_occ, wrap_occ] | otherwise = [con_occ, work_occ] @@ -369,10 +402,15 @@ ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons}) wrap_occ = mkDataConWrapperOcc con_occ work_occ = mkDataConWorkerOcc con_occ has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh) + || not (null . ifConEqSpec $ con_decl) + || isJust famInst -- ToDo: may miss strictness in existential dicts -ifaceDeclSubBndrs _other = [] +ifaceDeclSubBndrs _other = [] +-- coercion for data/newtype family instances +famInstCo Nothing baseOcc = [] +famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc] \end{code} @@ -383,8 +421,7 @@ ifaceDeclSubBndrs _other = [] %********************************************************* \begin{code} -findAndReadIface :: Bool -- True <=> explicit user import - -> SDoc -> Module +findAndReadIface :: SDoc -> Module -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath)) @@ -394,74 +431,63 @@ findAndReadIface :: Bool -- True <=> explicit user import -- It *doesn't* add an error to the monad, because -- sometimes it's ok to fail... see notes with loadInterface -findAndReadIface explicit doc_str mod_name hi_boot_file +findAndReadIface doc_str mod hi_boot_file = do { traceIf (sep [hsep [ptext SLIT("Reading"), if hi_boot_file then ptext SLIT("[boot]") else empty, ptext SLIT("interface for"), - ppr mod_name <> semi], + ppr mod <> semi], nest 4 (ptext SLIT("reason:") <+> doc_str)]) -- Check for GHC.Prim, and return its static interface ; dflags <- getDOpts - ; let base_pkg = basePackageId (pkgState dflags) - ; if mod_name == gHC_PRIM - then returnM (Succeeded (ghcPrimIface{ mi_package = base_pkg }, - "")) + ; if mod == gHC_PRIM + then returnM (Succeeded (ghcPrimIface, + "")) else do -- Look for the file ; hsc_env <- getTopEnv - ; mb_found <- ioToIOEnv (findHiFile hsc_env explicit mod_name hi_boot_file) + ; mb_found <- ioToIOEnv (findHiFile hsc_env mod hi_boot_file) ; case mb_found of { Failed err -> do { traceIf (ptext SLIT("...not found")) ; dflags <- getDOpts - ; returnM (Failed (cantFindError dflags mod_name err)) } ; + ; returnM (Failed (cannotFindInterface dflags + (moduleName mod) err)) } ; - Succeeded (file_path, pkg) -> do + Succeeded file_path -> do -- Found file, so read it { traceIf (ptext SLIT("readIFace") <+> text file_path) - ; read_result <- readIface mod_name file_path hi_boot_file + ; read_result <- readIface mod file_path hi_boot_file ; case read_result of Failed err -> returnM (Failed (badIfaceFile file_path err)) Succeeded iface - | mi_module iface /= mod_name -> - return (Failed (wrongIfaceModErr iface mod_name file_path)) + | mi_module iface /= mod -> + return (Failed (wrongIfaceModErr iface mod file_path)) | otherwise -> - returnM (Succeeded (iface{mi_package=pkg}, file_path)) + returnM (Succeeded (iface, file_path)) -- Don't forget to fill in the package name... }}} -findHiFile :: HscEnv -> Bool -> Module -> IsBootInterface - -> IO (MaybeErr FindResult (FilePath, PackageIdH)) -findHiFile hsc_env explicit mod_name hi_boot_file - = do { - -- In interactive or --make mode, we are *not allowed* to demand-load - -- a home package .hi file. So don't even look for them. - -- This helps in the case where you are sitting in eg. ghc/lib/std - -- and start up GHCi - it won't complain that all the modules it tries - -- to load are found in the home location. - let { home_allowed = isOneShot (ghcMode (hsc_dflags hsc_env)) } ; - maybe_found <- if home_allowed - then findModule hsc_env mod_name explicit - else findPackageModule hsc_env mod_name explicit; - - case maybe_found of - Found loc pkg -> return (Succeeded (path, pkg)) - where - path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) - - err -> return (Failed err) - } +findHiFile :: HscEnv -> Module -> IsBootInterface + -> IO (MaybeErr FindResult FilePath) +findHiFile hsc_env mod hi_boot_file + = do + maybe_found <- findExactModule hsc_env mod + case maybe_found of + Found loc mod -> return (Succeeded path) + where + path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) + err -> return (Failed err) \end{code} @readIface@ tries just the one file. \begin{code} -readIface :: Module -> String -> IsBootInterface +readIface :: Module -> FilePath -> IsBootInterface -> TcRnIf gbl lcl (MaybeErr Message ModIface) -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed @@ -493,7 +519,7 @@ readIface wanted_mod file_path is_hi_boot_file initExternalPackageState :: ExternalPackageState initExternalPackageState = EPS { - eps_is_boot = emptyModuleEnv, + eps_is_boot = emptyUFM, eps_PIT = emptyPackageIfaceTable, eps_PTE = emptyTypeEnv, eps_inst_env = emptyInstEnv, @@ -515,7 +541,7 @@ initExternalPackageState \begin{code} ghcPrimIface :: ModIface ghcPrimIface - = (emptyModIface HomePackage gHC_PRIM) { + = (emptyModIface gHC_PRIM) { mi_exports = [(gHC_PRIM, ghcPrimExports)], mi_decls = [], mi_fixities = fixities, @@ -550,6 +576,120 @@ ifaceStats eps \end{code} +%************************************************************************ +%* * + Printing interfaces +%* * +%************************************************************************ + +\begin{code} +showIface :: FilePath -> IO () +-- Read binary interface, and print it out +showIface filename = do + -- skip the version check; we don't want to worry about profiled vs. + -- non-profiled interfaces, for example. + writeIORef v_IgnoreHiWay True + iface <- Binary.getBinFileWithDict filename + printDump (pprModIface iface) + where +\end{code} + + +\begin{code} +pprModIface :: ModIface -> SDoc +-- Show a ModIface +pprModIface iface + = vcat [ ptext SLIT("interface") + <+> ppr (mi_module iface) <+> pp_boot + <+> ppr (mi_mod_vers iface) <+> pp_sub_vers + <+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty) + <+> int opt_HiVersion + <+> ptext SLIT("where") + , vcat (map pprExport (mi_exports iface)) + , pprDeps (mi_deps iface) + , vcat (map pprUsage (mi_usages iface)) + , pprFixities (mi_fixities iface) + , vcat (map pprIfaceDecl (mi_decls iface)) + , vcat (map ppr (mi_insts iface)) + , vcat (map ppr (mi_rules iface)) + , pprDeprecs (mi_deprecs iface) + ] + where + pp_boot | mi_boot iface = ptext SLIT("[boot]") + | otherwise = empty + + exp_vers = mi_exp_vers iface + rule_vers = mi_rule_vers iface + + pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty + | otherwise = brackets (ppr exp_vers <+> ppr rule_vers) +\end{code} + +When printing export lists, we print like this: + Avail f f + AvailTC C [C, x, y] C(x,y) + AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C + +\begin{code} +pprExport :: IfaceExport -> SDoc +pprExport (mod, items) + = hsep [ ptext SLIT("export"), ppr mod, hsep (map pp_avail items) ] + where + pp_avail :: GenAvailInfo OccName -> SDoc + pp_avail (Avail occ) = ppr occ + pp_avail (AvailTC _ []) = empty + pp_avail (AvailTC n (n':ns)) + | n==n' = ppr n <> pp_export ns + | otherwise = ppr n <> char '|' <> pp_export (n':ns) + + pp_export [] = empty + pp_export names = braces (hsep (map ppr names)) + +pprUsage :: Usage -> SDoc +pprUsage usage + = hsep [ptext SLIT("import"), ppr (usg_name usage), + int (usg_mod usage), + pp_export_version (usg_exports usage), + int (usg_rules usage), + pp_versions (usg_entities usage) ] + where + pp_versions nvs = hsep [ ppr n <+> int v | (n,v) <- nvs ] + pp_export_version Nothing = empty + pp_export_version (Just v) = int v + +pprDeps :: Dependencies -> SDoc +pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs}) + = vcat [ptext SLIT("module dependencies:") <+> fsep (map ppr_mod mods), + ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs), + ptext SLIT("orphans:") <+> fsep (map ppr orphs) + ] + where + ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot + ppr_boot True = text "[boot]" + ppr_boot False = empty + +pprIfaceDecl :: (Version, IfaceDecl) -> SDoc +pprIfaceDecl (ver, decl) + = ppr_vers ver <+> ppr decl + where + -- Print the version for the decl + ppr_vers v | v == initialVersion = empty + | otherwise = int v + +pprFixities :: [(OccName, Fixity)] -> SDoc +pprFixities [] = empty +pprFixities fixes = ptext SLIT("fixities") <+> pprWithCommas pprFix fixes + where + pprFix (occ,fix) = ppr fix <+> ppr occ + +pprDeprecs NoDeprecs = empty +pprDeprecs (DeprecAll txt) = ptext SLIT("Deprecate all") <+> doubleQuotes (ftext txt) +pprDeprecs (DeprecSome prs) = ptext SLIT("Deprecate") <+> vcat (map pprDeprec prs) + where + pprDeprec (name, txt) = ppr name <+> doubleQuotes (ftext txt) +\end{code} + + %********************************************************* %* * \subsection{Errors} @@ -563,7 +703,10 @@ badIfaceFile file err hiModuleNameMismatchWarn :: Module -> Module -> Message hiModuleNameMismatchWarn requested_mod read_mod = - hsep [ ptext SLIT("Something is amiss; requested module name") + withPprStyle defaultUserStyle $ + -- we want the Modules below to be qualified with package names, + -- so reset the PrintUnqualified setting. + hsep [ ptext SLIT("Something is amiss; requested module ") , ppr requested_mod , ptext SLIT("differs from name found in the interface file") , ppr read_mod @@ -580,3 +723,4 @@ wrongIfaceModErr iface mod_name file_path ] where iface_file = doubleQuotes (text file_path) \end{code} +