-
+%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section{Dealing with interface files}
+
+Loading interface files
\begin{code}
module LoadIface (
loadDecls, -- Should move to TcIface and be renamed
initExternalPackageState,
- ifaceStats, pprModIface, showIface -- Print the iface in Foo.hi
+ ifaceStats, pprModIface, showIface
) where
#include "HsVersions.h"
import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
tcIfaceFamInst )
-import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) )
-import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..),
- IfaceConDecls(..), IfaceFamInst(..) )
-import IfaceEnv ( newGlobalBinder, lookupIfaceTc )
-import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..),
- Deprecs(..), Dependencies(..),
- emptyModIface, EpsStats(..), GenAvailInfo(..),
- addEpsInStats, ExternalPackageState(..),
- PackageTypeEnv, emptyTypeEnv, HscEnv(..),
- lookupIfaceByModule, emptyPackageIfaceTable,
- IsBootInterface, mkIfaceFixCache,
- implicitTyThings
- )
-
-import BasicTypes ( Version, initialVersion,
- Fixity(..), FixityDirection(..), isMarkedStrict )
+import DynFlags
+import IfaceSyn
+import IfaceEnv
+import HscTypes
+
+import BasicTypes hiding (SuccessFlag(..))
import TcRnMonad
-import Type ( TyThing(..) )
-
-import PrelNames ( gHC_PRIM )
-import PrelInfo ( ghcPrimExports )
-import PrelRules ( builtinRules )
-import Rules ( extendRuleBaseList, mkRuleBase )
-import InstEnv ( emptyInstEnv, extendInstEnvList )
-import FamInstEnv ( emptyFamInstEnv, extendFamInstEnvList )
-import Name ( Name {-instance NamedThing-}, getOccName,
- nameModule, nameIsLocalOrFrom, isWiredInName )
+import Type
+
+import PrelNames
+import PrelInfo
+import PrelRules
+import Rules
+import InstEnv
+import FamInstEnv
+import Name
import NameEnv
-import MkId ( seqId )
+import MkId
import Module
-import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc,
- mkClassDataConOcc, mkSuperDictSelOcc,
- mkDataConWrapperOcc, mkDataConWorkerOcc,
- mkNewTyCoOcc, mkInstTyCoOcc )
-import SrcLoc ( importedSrcLoc )
-import Maybes ( MaybeErr(..) )
-import ErrUtils ( Message )
-import Finder ( findImportedModule, findExactModule,
- FindResult(..), cannotFindInterface )
+import OccName
+import SrcLoc
+import Maybes
+import ErrUtils
+import Finder
import UniqFM
-import StaticFlags ( opt_HiVersion )
+import StaticFlags
import Outputable
-import BinIface ( readBinIface, v_IgnoreHiWay )
-import Binary ( getBinFileWithDict )
-import Panic ( ghcError, tryMost, showException, GhcException(..) )
-import List ( nub )
-import Maybe ( isJust )
-import DATA_IOREF ( writeIORef )
+import BinIface
+import Panic
+
+import Data.List
+import Data.Maybe
+import Data.IORef
\end{code}
failWithTc (cannotFindInterface dflags mod err)
-- | Load interfaces for a collection of orphan modules.
-loadOrphanModules :: [Module] -> TcM ()
-loadOrphanModules mods
+loadOrphanModules :: [Module] -- the modules
+ -> Bool -- these are family instance-modules
+ -> TcM ()
+loadOrphanModules mods isFamInstMod
| null mods = returnM ()
| otherwise = initIfaceTcRn $
do { traceIf (text "Loading orphan modules:" <+>
; returnM () }
where
load mod = loadSysInterface (mk_doc mod) mod
- mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module")
+ mk_doc mod
+ | isFamInstMod = ppr mod <+> ptext SLIT("is a family-instance module")
+ | otherwise = ppr mod <+> ptext SLIT("is a orphan-instance module")
-- | Loads the interface for a given Name.
loadInterfaceForName :: SDoc -> Name -> TcRn ModIface
; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
- ; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT",
- mi_insts = panic "No mi_insts in PIT",
- mi_rules = panic "No mi_rules in PIT" } }
+ ; let { final_iface = iface {
+ mi_decls = panic "No mi_decls in PIT",
+ mi_insts = panic "No mi_insts in PIT",
+ mi_fam_insts = panic "No mi_fam_insts in PIT",
+ mi_rules = panic "No mi_rules in PIT"
+ } }
; updateEps_ $ \ eps ->
eps {
new_eps_insts,
eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
new_eps_fam_insts,
+ eps_mod_fam_inst_env
+ = let
+ fam_inst_env =
+ extendFamInstEnvList emptyFamInstEnv
+ new_eps_fam_insts
+ in
+ extendModuleEnv (eps_mod_fam_inst_env eps)
+ mod
+ fam_inst_env,
eps_stats = addEpsInStats (eps_stats eps)
(length new_eps_decls)
(length new_eps_insts) (length new_eps_rules) }
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)
- ; parent_name <- case ifFamily decl of -- make family the parent
- Just famTyCon -> lookupIfaceTc famTyCon
- _ -> return main_name
- ; implicit_names <- mapM (mk_new_bndr mod (Just parent_name))
- (ifaceDeclSubBndrs decl)
+ main_name <- mk_new_bndr mod (ifName decl)
+ ; traceIf (text "Loading decl for " <> ppr main_name)
+ ; implicit_names <- mapM (mk_new_bndr mod) (ifaceDeclSubBndrs decl)
-- Typecheck the thing, lazily
-- NB. Firstly, the laziness is there in case we never need the
-- * parent
-- * location
-- imported name, to fix the module correctly in the cache
- mk_new_bndr mod mb_parent occ
- = newGlobalBinder mod occ mb_parent
+ mk_new_bndr mod occ
+ = newGlobalBinder mod occ
(importedSrcLoc (showSDoc (ppr (moduleName mod))))
-- ToDo: qualify with the package name if necessary
- ifFamily (IfaceData {ifFamInst = Just (famTyCon, _)}) = Just famTyCon
- ifFamily _ = Nothing
-
doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used
; updateEps_ (\eps -> let stats = eps_stats eps
in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
}
-
------------------
-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
---
--- 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
- 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}
- = []
--- Newtype
-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
- dc_occs con_decl
- | has_wrapper = [con_occ, work_occ, wrap_occ]
- | otherwise = [con_occ, work_occ]
- where
- con_occ = ifConOcc con_decl
- strs = ifConStricts con_decl
- 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 = []
-
--- coercion for data/newtype family instances
-famInstCo Nothing baseOcc = []
-famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
\end{code}
readIface wanted_mod file_path is_hi_boot_file
= do { dflags <- getDOpts
- ; ioToIOEnv $ do
- { res <- tryMost (readBinIface file_path)
+ ; res <- tryMostM $ readBinIface file_path
; case res of
Right iface
| wanted_mod == actual_mod -> return (Succeeded iface)
err = hiModuleNameMismatchWarn wanted_mod actual_mod
Left exn -> return (Failed (text (showException exn)))
- }}
+ }
\end{code}
eps_fam_inst_env = emptyFamInstEnv,
eps_rule_base = mkRuleBase builtinRules,
-- Initialise the EPS rule pool with the built-in rules
+ eps_mod_fam_inst_env
+ = emptyModuleEnv,
eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
, n_insts_in = 0, n_insts_out = 0
, n_rules_in = length builtinRules, n_rules_out = 0 }
%************************************************************************
\begin{code}
-showIface :: FilePath -> IO ()
--- Read binary interface, and print it out
-showIface filename = do
+-- | Read binary interface, and print it out
+showIface :: HscEnv -> FilePath -> IO ()
+showIface hsc_env 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
+ iface <- initTcRnIf 's' hsc_env () () $ readBinIface filename
printDump (pprModIface iface)
- where
\end{code}
-
\begin{code}
pprModIface :: ModIface -> SDoc
-- Show a ModIface
<+> 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)
+ <+> (if mi_finsts iface then ptext SLIT("[family instance module]") else empty)
<+> int opt_HiVersion
<+> ptext SLIT("where")
, vcat (map pprExport (mi_exports iface))
, pprFixities (mi_fixities iface)
, vcat (map pprIfaceDecl (mi_decls iface))
, vcat (map ppr (mi_insts iface))
+ , vcat (map ppr (mi_fam_insts iface))
, vcat (map ppr (mi_rules iface))
, pprDeprecs (mi_deprecs iface)
]
pp_export_version (Just v) = int v
pprDeps :: Dependencies -> SDoc
-pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs})
+pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
+ dep_finsts = finsts })
= 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)
+ ptext SLIT("orphans:") <+> fsep (map ppr orphs),
+ ptext SLIT("family instance modules:") <+> fsep (map ppr finsts)
]
where
ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot