module Module where
-
+import GHC.Base
data Module
#include "HsVersions.h"
import BasicTypes ( Boxity(..) )
+import PackageConfig ( PackageId, packageIdFS )
import FastString ( FastString, uniqueOfFS )
import Outputable
import FastTypes
instance Uniquable FastString where
getUnique fs = mkUniqueGrimily (I# (uniqueOfFS fs))
+instance Uniquable PackageId where
+ getUnique pid = getUnique (packageIdFS pid)
+
instance Uniquable Int where
getUnique i = mkUniqueGrimily i
\end{code}
%
\begin{code}
module CompManager (
- ModuleGraph, ModSummary(..),
+ ModSummary, -- Abstract
+ ModuleGraph, -- All the modules from the home package
- CmState, -- abstract
+ CmState, -- Abstract
cmInit, -- :: GhciMode -> IO CmState
cmGetInfo, -- :: CmState -> String -> IO (CmState, [(TyThing,Fixity)])
GetInfoResult,
cmBrowseModule, -- :: CmState -> IO [TyThing]
+ cmShowModule,
CmRunResult(..),
cmRunStmt, -- :: CmState -> String -> IO (CmState, CmRunResult)
HValue,
cmCompileExpr, -- :: CmState -> String -> IO (CmState, Maybe HValue)
-
- cmGetModInfo, -- :: CmState -> (ModuleGraph, HomePackageTable)
-
+ cmGetModuleGraph, -- :: CmState -> ModuleGraph
cmSetDFlags,
cmGetDFlags,
#include "HsVersions.h"
-import Packages ( isHomeModule )
+import Packages ( isHomePackage )
import DriverPipeline ( CompResult(..), preprocess, compile, link )
import HscMain ( newHscEnv )
import DriverState ( v_Output_file, v_NoHsMain, v_MainModIs )
import Finder
import HscTypes
import PrelNames ( gHC_PRIM )
-import Module ( Module, mkModule,
- ModuleEnv, lookupModuleEnv, mkModuleEnv,
- moduleEnvElts, extendModuleEnvList, extendModuleEnv,
+import Module ( Module, mkModule, delModuleEnvList, mkModuleEnv,
+ lookupModuleEnv, moduleEnvElts, extendModuleEnv,
moduleUserString,
ModLocation(..) )
import GetImports
import LoadIface ( noIfaceErr )
-import UniqFM
import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
import ErrUtils ( showPass )
import SysTools ( cleanTempFilesExcept )
import Util
import Outputable
import Panic
-import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt_unset )
+import CmdLineOpts ( DynFlags(..) )
import Maybes ( expectJust, orElse, mapCatMaybes )
+import FiniteMap
import DATA_IOREF ( readIORef )
import TcRnDriver ( mkExportEnv, getModuleContents )
import IfaceSyn ( IfaceDecl )
import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv )
+import Module ( showModMsg )
import Name ( Name )
import NameEnv
import Id ( idType )
import Foreign
import SrcLoc ( SrcLoc )
import Control.Exception as Exception ( Exception, try )
+import CmdLineOpts ( DynFlag(..), dopt_unset )
#endif
import EXCEPTION ( throwDyn )
\end{code}
+%************************************************************************
+%* *
+ The module dependency graph
+ ModSummary, ModGraph, NodeKey, NodeMap
+%* *
+%************************************************************************
+
+The nodes of the module graph are
+ EITHER a regular Haskell source module
+ OR a hi-boot source module
+
+A ModuleGraph contains all the nodes from the home package (only).
+There will be a node for each source module, plus a node for each hi-boot
+module.
+
+\begin{code}
+type ModuleGraph = [ModSummary] -- The module graph,
+ -- NOT NECESSARILY IN TOPOLOGICAL ORDER
+
+emptyMG :: ModuleGraph
+emptyMG = []
+
+--------------------
+data ModSummary
+ = ModSummary {
+ ms_mod :: Module, -- Name of the module
+ ms_boot :: IsBootInterface, -- Whether this is an hi-boot file
+ ms_location :: ModLocation, -- Location
+ ms_srcimps :: [Module], -- Source imports
+ ms_imps :: [Module], -- Non-source imports
+ ms_hs_date :: ClockTime -- Timestamp of summarised file
+ }
+
+-- The ModLocation contains both the original source filename and the
+-- filename of the cleaned-up source file after all preprocessing has been
+-- done. The point is that the summariser will have to cpp/unlit/whatever
+-- all files anyway, and there's no point in doing this twice -- just
+-- park the result in a temp file, put the name of it in the location,
+-- and let @compile@ read from that file on the way back up.
+
+instance Outputable ModSummary where
+ ppr ms
+ = sep [text "ModSummary {",
+ nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),
+ text "ms_mod =" <+> ppr (ms_mod ms) <> comma,
+ text "ms_imps =" <+> ppr (ms_imps ms),
+ text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),
+ char '}'
+ ]
+
+ms_allimps ms = ms_srcimps ms ++ ms_imps ms
+
+--------------------
+type NodeKey = (Module, IsBootInterface) -- The nodes of the graph are
+type NodeMap a = FiniteMap NodeKey a -- keyed by (mod,boot) pairs
+
+msKey :: ModSummary -> NodeKey
+msKey (ModSummary { ms_mod = mod, ms_boot = boot }) = (mod,boot)
+
+emptyNodeMap :: NodeMap a
+emptyNodeMap = emptyFM
+
+mkNodeMap :: [(NodeKey,a)] -> NodeMap a
+mkNodeMap = listToFM
+
+nodeMapElts :: NodeMap a -> [a]
+nodeMapElts = eltsFM
+\end{code}
+
+
+%************************************************************************
+%* *
+ The compilation manager state
+%* *
+%************************************************************************
+
+
\begin{code}
-- Persistent state for the entire system
data CmState
}
#ifdef GHCI
-cmGetModInfo cmstate = (cm_mg cmstate, hsc_HPT (cm_hsc cmstate))
+cmGetModuleGraph cmstate = cm_mg cmstate
cmGetBindings cmstate = nameEnvElts (ic_type_env (cm_ic cmstate))
cmGetPrintUnqual cmstate = icPrintUnqual (cm_ic cmstate)
cmHPT cmstate = hsc_HPT (cm_hsc cmstate)
-----------------------------------------------------------------------------
+cmShowModule :: CmState -> ModSummary -> String
+cmShowModule cmstate mod_summary
+ = case lookupModuleEnv hpt mod of
+ Nothing -> panic "missing linkable"
+ Just mod_info -> showModMsg obj_linkable mod locn
+ where
+ obj_linkable = isObjectLinkable (hm_linkable mod_info)
+ where
+ hpt = hsc_HPT (cm_hsc cmstate)
+ mod = ms_mod mod_summary
+ locn = ms_location mod_summary
+
+-----------------------------------------------------------------------------
-- cmRunStmt: Run a statement/expr.
data CmRunResult
-- the system state at the same time.
cmLoadModules :: CmState -- The HPT may not be as up to date
- -> ModuleGraph -- Bang up to date
+ -> ModuleGraph -- Bang up to date; but may contain hi-boot no
-> IO (CmState, -- new state
SuccessFlag, -- was successful
[String]) -- list of modules loaded
let mg2unsorted_names = map ms_mod mg2unsorted
- -- reachable_from follows source as well as normal imports
- let reachable_from :: Module -> [Module]
- reachable_from = downwards_closure_of_module mg2unsorted
-
- -- should be cycle free; ignores 'import source's
- let mg2 = topological_sort False mg2unsorted
- -- ... whereas this takes them into account. Used for
+ -- mg2 should be cycle free; but it includes hi-boot ModSummary nodes
+ let mg2 :: [SCC ModSummary]
+ mg2 = topological_sort False mg2unsorted
+
+ -- mg2_with_srcimps drops the hi-boot nodes, returning a
+ -- graph with cycles. Among other things, it is used for
-- backing out partially complete cycles following a failed
-- upsweep, and for removing from hpt all the modules
-- not in strict downwards closure, during calls to compile.
- let mg2_with_srcimps = topological_sort True mg2unsorted
+ let mg2_with_srcimps :: [SCC ModSummary]
+ mg2_with_srcimps = topological_sort True mg2unsorted
-- Sort out which linkables we wish to keep in the unlinked image.
-- See getValidLinkables below for details.
-- putStrLn (showSDoc (vcat [ppr valid_old_linkables, ppr new_linkables]))
- let hpt2 = delListFromUFM hpt1 (map linkableModule new_linkables)
+ let hpt2 = delModuleEnvList hpt1 (map linkableModule new_linkables)
hsc_env2 = hsc_env { hsc_HPT = hpt2 }
-- When (verb >= 2) $
-- 1. All home imports of ms are either in ms or S
-- 2. A valid old linkable exists for each module in ms
- stable_mods <- preUpsweep valid_old_linkables
- mg2unsorted_names [] mg2_with_srcimps
-
- let stable_summaries
- = concatMap (findInSummaries mg2unsorted) stable_mods
-
- stable_linkables
- = filter (\m -> linkableModule m `elem` stable_mods)
- valid_old_linkables
+ -- mg2_with_srcimps has no hi-boot nodes,
+ -- and hence neither does stable_mods
+ stable_summaries <- preUpsweep valid_old_linkables
+ mg2unsorted_names [] mg2_with_srcimps
+ let stable_mods = map ms_mod stable_summaries
+ stable_linkables = filter (\m -> linkableModule m `elem` stable_mods)
+ valid_old_linkables
when (verb >= 2) $
hPutStrLn stderr (showSDoc (text "Stable modules:"
(ppFilesFromSummaries (flattenSCCs mg2))
(upsweep_ok, hsc_env3, modsUpswept)
- <- upsweep_mods hsc_env2 valid_linkables reachable_from
+ <- upsweep_mods hsc_env2 valid_linkables
cleanup upsweep_these
-- At this point, modsUpswept and newLis should have the same
[Linkable] -- new linkables we just found
)
-getValidLinkables mode old_linkables all_home_mods module_graph = do
- ls <- foldM (getValidLinkablesSCC mode old_linkables all_home_mods)
- [] module_graph
- return (partition_it ls [] [])
+getValidLinkables mode old_linkables all_home_mods module_graph
+ = do { -- Process the SCCs in bottom-to-top order
+ -- (foldM works left-to-right)
+ ls <- foldM (getValidLinkablesSCC mode old_linkables all_home_mods)
+ [] module_graph
+ ; return (partition_it ls [] []) }
where
partition_it [] valid new = (valid,new)
partition_it ((l,b):ls) valid new
| otherwise = partition_it ls (l:valid) new
+getValidLinkablesSCC
+ :: GhciMode
+ -> [Linkable] -- old linkables
+ -> [Module] -- all home modules
+ -> [(Linkable,Bool)]
+ -> SCC ModSummary
+ -> IO [(Linkable,Bool)]
+
getValidLinkablesSCC mode old_linkables all_home_mods new_linkables scc0
= let
scc = flattenSCC scc0
-- force a module's SOURCE imports to be already compiled for
-- its object linkable to be valid.
- has_object m =
- case findModuleLinkable_maybe (map fst new_linkables) m of
- Nothing -> False
- Just l -> isObjectLinkable l
+ -- The new_linkables is only the *valid* linkables below here
+ has_object m = case findModuleLinkable_maybe (map fst new_linkables) m of
+ Nothing -> False
+ Just l -> isObjectLinkable l
objects_allowed = mode == Batch || all has_object scc_allhomeimps
in do
preUpsweep :: [Linkable] -- new valid linkables
-> [Module] -- names of all mods encountered in downsweep
- -> [Module] -- accumulating stable modules
+ -> [ModSummary] -- accumulating stable modules
-> [SCC ModSummary] -- scc-ified mod graph, including src imps
- -> IO [Module] -- stable modules
+ -> IO [ModSummary] -- stable modules
preUpsweep valid_lis all_home_mods stable [] = return stable
preUpsweep valid_lis all_home_mods stable (scc0:sccs)
= nub (filter (`elem` all_home_mods) (concatMap ms_allimps scc))
all_imports_in_scc_or_stable
= all in_stable_or_scc scc_allhomeimps
- scc_names
- = map ms_mod scc
- in_stable_or_scc m
- = m `elem` scc_names || m `elem` stable
+ scc_mods = map ms_mod scc
+ stable_names = scc_mods ++ map ms_mod stable
+ in_stable_or_scc m = m `elem` stable_names
-- now we check for valid linkables: each module in the SCC must
-- have a valid linkable (see getValidLinkables above).
- has_valid_linkable new_summary
- = isJust (findModuleLinkable_maybe valid_lis modname)
- where modname = ms_mod new_summary
+ has_valid_linkable scc_mod
+ = isJust (findModuleLinkable_maybe valid_lis scc_mod)
scc_is_stable = all_imports_in_scc_or_stable
- && all has_valid_linkable scc
+ && all has_valid_linkable scc_mods
if scc_is_stable
- then preUpsweep valid_lis all_home_mods (scc_names++stable) sccs
- else preUpsweep valid_lis all_home_mods stable sccs
+ then preUpsweep valid_lis all_home_mods (scc ++ stable) sccs
+ else preUpsweep valid_lis all_home_mods stable sccs
--- Helper for preUpsweep. Assuming that new_summary's imports are all
--- stable (in the sense of preUpsweep), determine if new_summary is itself
--- stable, and, if so, in batch mode, return its linkable.
-findInSummaries :: [ModSummary] -> Module -> [ModSummary]
-findInSummaries old_summaries mod_name
- = [s | s <- old_summaries, ms_mod s == mod_name]
-
-findModInSummaries :: [ModSummary] -> Module -> Maybe ModSummary
-findModInSummaries old_summaries mod
- = case [s | s <- old_summaries, ms_mod s == mod] of
- [] -> Nothing
- (s:_) -> Just s
-
-- Return (names of) all those in modsDone who are part of a cycle
-- as defined by theGraph.
findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
-- There better had not be any cyclic groups here -- we check for them.
upsweep_mods :: HscEnv -- Includes up-to-date HPT
-> [Linkable] -- Valid linkables
- -> (Module -> [Module]) -- to construct downward closures
-> IO () -- how to clean up unwanted tmp files
-> [SCC ModSummary] -- mods to do (the worklist)
-- ...... RETURNING ......
HscEnv, -- With an updated HPT
[ModSummary]) -- Mods which succeeded
-upsweep_mods hsc_env oldUI reachable_from cleanup
+upsweep_mods hsc_env oldUI cleanup
[]
= return (Succeeded, hsc_env, [])
-upsweep_mods hsc_env oldUI reachable_from cleanup
- ((CyclicSCC ms):_)
+upsweep_mods hsc_env oldUI cleanup
+ (CyclicSCC ms:_)
= do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++
unwords (map (moduleUserString.ms_mod) ms))
return (Failed, hsc_env, [])
-upsweep_mods hsc_env oldUI reachable_from cleanup
- ((AcyclicSCC mod):mods)
+upsweep_mods hsc_env oldUI cleanup
+ (AcyclicSCC mod:mods)
= do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
- -- show (map (moduleUserString.moduleName.mi_module.hm_iface) (eltsUFM (hsc_HPT hsc_env)))
+ -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
+ -- (moduleEnvElts (hsc_HPT hsc_env)))
(ok_flag, hsc_env1) <- upsweep_mod hsc_env oldUI mod
- (reachable_from (ms_mod mod))
cleanup -- Remove unwanted tmp files between compilations
if failed ok_flag then
return (Failed, hsc_env1, [])
else do
- (restOK, hsc_env2, modOKs)
- <- upsweep_mods hsc_env1 oldUI reachable_from cleanup mods
+ (restOK, hsc_env2, modOKs) <- upsweep_mods hsc_env1 oldUI cleanup mods
return (restOK, hsc_env2, mod:modOKs)
upsweep_mod :: HscEnv
-> UnlinkedImage
-> ModSummary
- -> [Module]
-> IO (SuccessFlag,
HscEnv) -- With updated HPT
-upsweep_mod hsc_env oldUI summary1 reachable_inc_me
+upsweep_mod hsc_env oldUI summary1
+ | ms_boot summary1 -- The summary describes an hi-boot file,
+ = -- so there is nothing to do
+ return (Succeeded, hsc_env)
+
+ | otherwise -- The summary describes a regular source file, so compile it
= do
let this_mod = ms_mod summary1
location = ms_location summary1
let maybe_old_linkable = findModuleLinkable_maybe oldUI this_mod
source_unchanged = isJust maybe_old_linkable
- reachable_only = filter (/= this_mod) reachable_inc_me
-
- -- In interactive mode, all home modules below us *must* have an
- -- interface in the HPT. We never demand-load home interfaces in
- -- interactive mode.
- hpt1_strictDC
- = ASSERT(hsc_mode hsc_env == Batch || all (`elemUFM` hpt1) reachable_only)
- retainInTopLevelEnvs reachable_only hpt1
- hsc_env_strictDC = hsc_env { hsc_HPT = hpt1_strictDC }
-
old_linkable = expectJust "upsweep_mod:old_linkable" maybe_old_linkable
have_object
| Just l <- maybe_old_linkable, isObjectLinkable l = True
| otherwise = False
- compresult <- compile hsc_env_strictDC this_mod location
+ compresult <- compile hsc_env this_mod location
(ms_hs_date summary1)
source_unchanged have_object mb_old_iface
-- Filter modules in the HPT
retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable
retainInTopLevelEnvs keep_these hpt
- = listToUFM (concatMap (maybeLookupUFM hpt) keep_these)
+ = mkModuleEnv [ (mod, fromJust mb_mod_info)
+ | mod <- keep_these
+ , let mb_mod_info = lookupModuleEnv hpt mod
+ , isJust mb_mod_info ]
+
+-----------------------------------------------------------------------------
+topological_sort :: Bool -- Drop hi-boot nodes? (see below)
+ -> [ModSummary]
+ -> [SCC ModSummary]
+-- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
+--
+-- Drop hi-boot nodes (first boolean arg)?
+--
+-- False: treat the hi-boot summaries as nodes of the graph,
+-- so the graph must be acyclic
+--
+-- True: eliminate the hi-boot nodes, and instead pretend
+-- the a source-import of Foo is an import of Foo
+-- The resulting graph has no hi-boot nodes, but can by cyclic
+
+topological_sort drop_hi_boot_nodes summaries
+ = stronglyConnComp nodes
where
- maybeLookupUFM ufm u = case lookupUFM ufm u of
- Nothing -> []
- Just val -> [(u, val)]
-
--- Needed to clean up HPT so that we don't get duplicates in inst env
-downwards_closure_of_module :: [ModSummary] -> Module -> [Module]
-downwards_closure_of_module summaries root
- = let toEdge :: ModSummary -> (Module,[Module])
- toEdge summ = (ms_mod summ,
- filter (`elem` all_mods) (ms_allimps summ))
-
- all_mods = map ms_mod summaries
-
- res = simple_transitive_closure (map toEdge summaries) [root]
- in
--- trace (showSDoc (text "DC of mod" <+> ppr root
--- <+> text "=" <+> ppr res)) $
- res
-
--- Calculate transitive closures from a set of roots given an adjacency list
-simple_transitive_closure :: Eq a => [(a,[a])] -> [a] -> [a]
-simple_transitive_closure graph set
- = let set2 = nub (concatMap dsts set ++ set)
- dsts node = fromMaybe [] (lookup node graph)
- in
- if length set == length set2
- then set
- else simple_transitive_closure graph set2
-
-
--- Calculate SCCs of the module graph, with or without taking into
--- account source imports.
-topological_sort :: Bool -> [ModSummary] -> [SCC ModSummary]
-topological_sort include_source_imports summaries
- = let
- toEdge :: ModSummary -> (ModSummary,Module,[Module])
- toEdge summ
- = (summ, ms_mod summ,
- (if include_source_imports
- then ms_srcimps summ else []) ++ ms_imps summ)
-
- mash_edge :: (ModSummary,Module,[Module]) -> (ModSummary,Int,[Int])
- mash_edge (summ, m, m_imports)
- = case lookup m key_map of
- Nothing -> panic "reverse_topological_sort"
- Just mk -> (summ, mk,
- -- ignore imports not from the home package
- mapCatMaybes (flip lookup key_map) m_imports)
-
- edges = map toEdge summaries
- key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(Module,Int)]
- scc_input = map mash_edge edges
- sccs = stronglyConnComp scc_input
- in
- sccs
+ keep_hi_boot_nodes = not drop_hi_boot_nodes
+
+ -- We use integers as the keys for the SCC algorithm
+ nodes :: [(ModSummary, Int, [Int])]
+ nodes = [(s, fromJust (lookup_key (ms_boot s) (ms_mod s)),
+ out_edge_keys keep_hi_boot_nodes (ms_srcimps s) ++
+ out_edge_keys False (ms_imps s) )
+ | s <- summaries
+ , not (ms_boot s) || keep_hi_boot_nodes ]
+ -- Drop the hi-boot ones if told to do so
+
+ key_map :: NodeMap Int
+ key_map = listToFM ([(ms_mod s, ms_boot s) | s <- summaries]
+ `zip` [1..])
+
+ lookup_key :: IsBootInterface -> Module -> Maybe Int
+ lookup_key hi_boot mod = lookupFM key_map (mod, hi_boot)
+
+ out_edge_keys :: IsBootInterface -> [Module] -> [Int]
+ out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
+ -- If we want keep_hi_boot_nodes, then we do lookup_key with
+ -- the IsBootInterface parameter True; else False
-----------------------------------------------------------------------------
downsweep dflags roots old_summaries
= do rootSummaries <- mapM getRootSummary roots
checkDuplicates rootSummaries
- all_summaries
- <- loop (concat (map (\ m -> zip (repeat (fromMaybe "<unknown>" (ml_hs_file (ms_location m))))
- (ms_imps m)) rootSummaries))
- (mkModuleEnv [ (mod, s) | s <- rootSummaries,
- let mod = ms_mod s,
- isHomeModule dflags mod
- ])
- return all_summaries
+ loop rootSummaries emptyNodeMap
where
+ old_summary_map :: NodeMap ModSummary
+ old_summary_map = mkNodeMap [ (msKey s, s) | s <- old_summaries]
+
getRootSummary :: FilePath -> IO ModSummary
getRootSummary file
| isHaskellSrcFilename file
exists <- doesFileExist lhs_file
if exists then summariseFile dflags lhs_file else do
let mod_name = mkModule file
- maybe_summary <- getSummary (file, mod_name)
+ maybe_summary <- getSummary file False {- Not hi-boot -} mod_name
case maybe_summary of
Nothing -> packageModErr mod_name
Just s -> return s
[ fromJust (ml_hs_file (ms_location summ'))
| summ' <- summaries, ms_mod summ' == modl ]
- getSummary :: (FilePath,Module) -> IO (Maybe ModSummary)
- getSummary (currentMod,mod)
- = do found <- findModule dflags mod True{-explicit-}
+ loop :: [ModSummary] -- Work list: process the imports of these modules
+ -> NodeMap ModSummary -- Visited set
+ -> IO [ModSummary] -- The result includes the worklist, except
+ -- for those mentioned in the visited set
+ loop [] done = return (nodeMapElts done)
+ loop (s:ss) done | key `elemFM` done = loop ss done
+ | otherwise = do { new_ss <- children s
+ ; loop (new_ss ++ ss) (addToFM done key s) }
+ where
+ key = (ms_mod s, ms_boot s)
+
+ children :: ModSummary -> IO [ModSummary]
+ children s = do { mb_kids1 <- mapM (getSummary cur_path True) (ms_srcimps s)
+ ; mb_kids2 <- mapM (getSummary cur_path False) (ms_imps s)
+ ; return (catMaybes mb_kids1 ++ catMaybes mb_kids2) }
+ -- The Nothings are the ones from other packages: ignore
+ where
+ cur_path = fromJust (ml_hs_file (ms_location s))
+
+ getSummary :: FilePath -- Import directive is in here [only used for err msg]
+ -> IsBootInterface -- Look for an hi-boot file?
+ -> Module -- Look for this module
+ -> IO (Maybe ModSummary)
+ getSummary cur_mod is_boot wanted_mod
+ = do found <- findModule dflags wanted_mod True {-explicit-}
case found of
- Found location pkg -> do
- let old_summary = findModInSummaries old_summaries mod
- summarise dflags mod location old_summary
-
- err -> throwDyn (noModError dflags currentMod mod err)
-
- -- loop invariant: env doesn't contain package modules
- loop :: [(FilePath,Module)] -> ModuleEnv ModSummary -> IO [ModSummary]
- loop [] env = return (moduleEnvElts env)
- loop imps env
- = do -- imports for modules we don't already have
- let needed_imps = nub (filter (not . (`elemUFM` env).snd) imps)
+ Found location pkg
+ | isHomePackage pkg -- Drop an external-package modules
+ -> do { let old_summary = lookupFM old_summary_map (wanted_mod, is_boot)
+ ; summarise dflags wanted_mod is_boot location old_summary }
+ | otherwise
+ -> return Nothing -- External package module
- -- summarise them
- needed_summaries <- mapM getSummary needed_imps
+ err -> throwDyn (noModError dflags cur_mod wanted_mod err)
- -- get just the "home" modules
- let new_home_summaries = [ s | Just s <- needed_summaries ]
-
- -- loop, checking the new imports
- let new_imps = concat (map (\ m -> zip (repeat (fromMaybe "<unknown>" (ml_hs_file (ms_location m))))
- (ms_imps m)) new_home_summaries)
- loop new_imps (extendModuleEnvList env
- [ (ms_mod s, s) | s <- new_home_summaries ])
-- ToDo: we don't have a proper line number for this error
noModError dflags loc mod_nm err
Nothing -> noHsFileErr mod
Just src_fn -> getModificationTime src_fn
- return (ModSummary { ms_mod = mod,
- ms_location = location{ ml_hspp_file = Just hspp_fn,
- ml_hspp_buf = Just buf },
+ return (ModSummary { ms_mod = mod, ms_boot = False,
+ ms_location = location{ml_hspp_file=Just hspp_fn},
ms_srcimps = srcimps, ms_imps = the_imps,
ms_hs_date = src_timestamp })
-- Summarise a module, and pick up source and timestamp.
-summarise :: DynFlags -> Module -> ModLocation -> Maybe ModSummary
- -> IO (Maybe ModSummary)
-summarise dflags mod location old_summary
- | not (isHomeModule dflags mod) = return Nothing
- | otherwise
- = do let hs_fn = expectJust "summarise" (ml_hs_file location)
-
- case ml_hs_file location of {
- Nothing -> noHsFileErr mod;
- Just src_fn -> do
-
- src_timestamp <- getModificationTime src_fn
+summarise :: DynFlags
+ -> Module -- Guaranteed a home-package module
+ -> IsBootInterface
+ -> ModLocation -> Maybe ModSummary
+ -> IO (Maybe ModSummary)
+summarise dflags mod is_boot location old_summary
+ = do { -- Find the source file to summarise
+ src_fn <- if is_boot then
+ hiBootFilePath location
+ else
+ case ml_hs_file location of
+ Nothing -> noHsFileErr mod
+ Just src_fn -> return src_fn
+
+ -- Find its timestamp
+ ; src_timestamp <- getModificationTime src_fn
-- return the cached summary if the source didn't change
- case old_summary of {
- Just s | ms_hs_date s == src_timestamp -> return (Just s);
- _ -> do
+ ; case old_summary of {
+ Just s | ms_hs_date s == src_timestamp -> return (Just s);
+ _ -> do
- hspp_fn <- preprocess dflags hs_fn
-
- buf <- hGetStringBuffer hspp_fn
- (srcimps,imps,mod_name) <- getImports dflags buf hspp_fn
- let
+ -- For now, we never pre-process hi-boot files
+ { hspp_fn <- if is_boot then return src_fn
+ else preprocess dflags src_fn
+
+ ; buf <- hGetStringBuffer hspp_fn
+ ; (srcimps,imps,mod_name) <- getImports dflags buf hspp_fn
+ ; let
-- GHC.Prim doesn't exist physically, so don't go looking for it.
- the_imps = filter (/= gHC_PRIM) imps
+ the_imps = filter (/= gHC_PRIM) imps
- when (mod_name /= mod) $
+ ; when (mod_name /= mod) $
throwDyn (ProgramError
- (showSDoc (text hs_fn
+ (showSDoc (text src_fn
<> text ": file name does not match module name"
<+> quotes (ppr mod))))
- return (Just (ModSummary mod location{ ml_hspp_file = Just hspp_fn,
- ml_hspp_buf = Just buf }
- srcimps the_imps src_timestamp))
- }
- }
-
+ ; let new_loc = location{ ml_hspp_file = Just hspp_fn,
+ ml_hspp_buf = Just buf }
+ ; return (Just (ModSummary mod is_boot new_loc
+ srcimps the_imps src_timestamp))
+ }}}
noHsFileErr mod
= throwDyn (CmdLineError (showSDoc (text "no source file for module" <+> quotes (ppr mod))))
\end{code}
-%************************************************************************
-%* *
- The ModSummary Type
-%* *
-%************************************************************************
-
-\begin{code}
--- The ModLocation contains both the original source filename and the
--- filename of the cleaned-up source file after all preprocessing has been
--- done. The point is that the summariser will have to cpp/unlit/whatever
--- all files anyway, and there's no point in doing this twice -- just
--- park the result in a temp file, put the name of it in the location,
--- and let @compile@ read from that file on the way back up.
-
-
-type ModuleGraph = [ModSummary] -- the module graph, topologically sorted
-
-emptyMG :: ModuleGraph
-emptyMG = []
-
-data ModSummary
- = ModSummary {
- ms_mod :: Module, -- name, package
- ms_location :: ModLocation, -- location
- ms_srcimps :: [Module], -- source imports
- ms_imps :: [Module], -- non-source imports
- ms_hs_date :: ClockTime -- timestamp of summarised file
- }
-
-instance Outputable ModSummary where
- ppr ms
- = sep [text "ModSummary {",
- nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),
- text "ms_mod =" <+> ppr (ms_mod ms) <> comma,
- text "ms_imps =" <+> ppr (ms_imps ms),
- text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),
- char '}'
- ]
-
-ms_allimps ms = ms_srcimps ms ++ ms_imps ms
-\end{code}
HsBindGroup(..), LRuleDecl, HsBind(..) )
import TcRnTypes ( TcGblEnv(..), ImportAvails(..) )
import MkIface ( mkUsageInfo )
-import Id ( Id, setIdExported, idName, idIsFrom, isLocalId )
+import Id ( Id, setIdExported, idName, idIsFrom )
import Name ( Name, isExternalName )
import CoreSyn
import PprCore ( pprIdRules, pprCoreExpr )
import Bag ( Bag, isEmptyBag, emptyBag, bagToList )
import CoreLint ( showPass, endPass )
import CoreFVs ( ruleRhsFreeVars )
-import Packages ( PackageState(thPackageId) )
+import Packages ( PackageState(thPackageId), PackageIdH(..) )
import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings,
errorsFound, WarnMsg )
import ListSetOps ( insertList )
; th_used <- readIORef th_var -- Whether TH is used
; let used_names = allUses dus `unionNameSets` dfun_uses
thPackage = thPackageId (pkgState dflags)
- pkgs | Just th_id <- thPackage, th_used
+ pkgs | ExtPackage th_id <- thPackage, th_used
= insertList th_id (imp_dep_pkgs imports)
| otherwise
= imp_dep_pkgs imports
data DsGblEnv = DsGblEnv {
ds_mod :: Module, -- For SCC profiling
ds_warns :: IORef (Bag DsWarning), -- Warning messages
- ds_if_env :: IfGblEnv -- Used for looking up global,
+ ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
-- possibly-imported things
}
initDs hsc_env mod rdr_env type_env thing_inside
= do { warn_var <- newIORef emptyBag
- ; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env) }
+ ; let { if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
+ ; if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
; gbl_env = DsGblEnv { ds_mod = mod,
- ds_if_env = if_env,
+ ds_if_env = (if_genv, if_lenv),
ds_warns = warn_var }
; lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
ds_loc = noSrcSpan } }
-- Very like TcEnv.tcLookupGlobal
dsLookupGlobal name
= do { env <- getGblEnv
- ; setEnvs (ds_if_env env, ())
+ ; setEnvs (ds_if_env env)
(tcIfaceGlobal name) }
dsLookupGlobalId :: Name -> DsM Id
{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.182 2005/01/12 12:44:25 ross Exp $
+-- $Id: InteractiveUI.hs,v 1.183 2005/01/18 12:18:19 simonpj Exp $
--
-- GHC Interactive User Interface
--
import DriverUtil ( remove_spaces )
import Linker ( showLinkerState, linkPackages )
import Util
-import Module ( showModMsg, lookupModuleEnv )
import Name ( Name, NamedThing(..) )
import OccName ( OccName, isSymOcc, occNameUserString )
import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) )
["linker"] -> io showLinkerState
_ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]")
-showModules = do
- cms <- getCmState
- let (mg, hpt) = cmGetModInfo cms
- mapM_ (showModule hpt) mg
-
-
-showModule :: HomePackageTable -> ModSummary -> GHCi ()
-showModule hpt mod_summary
- = case lookupModuleEnv hpt mod of
- Nothing -> panic "missing linkable"
- Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn))
- where
- obj_linkable = isObjectLinkable (hm_linkable mod_info)
- where
- mod = ms_mod mod_summary
- locn = ms_location mod_summary
+showModules
+ = do { cms <- getCmState
+ ; let show_one ms = io (putStrLn (cmShowModule cms ms))
+ ; mapM_ show_one (cmGetModuleGraph cms) }
showBindings = do
cms <- getCmState
-- The linker's symbol table is populated with RTS symbols using an
-- explicit list. See rts/Linker.c for details.
where init_pkgs
- | Just rts_id <- rtsPackageId (pkgState dflags) = [rts_id]
+ | ExtPackage rts_id <- rtsPackageId (pkgState dflags) = [rts_id]
| otherwise = []
\end{code}
-- Get the things needed for the specified module
-- This is rather similar to the code in RnNames.importsFromImportDecl
get_deps mod
- | ExternalPackage p <- mi_package iface
+ | ExtPackage p <- mi_package iface
= ([], p : dep_pkgs deps)
| otherwise
= (mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps)
import NewDemand
import IfaceSyn
import VarEnv
+import Packages ( PackageIdH(..) )
import Class ( DefMeth(..) )
import CostCentre
import DriverState ( v_Build_tag )
rules <- {-# SCC "bin_rules" #-} lazyGet bh
rule_vers <- get bh
return (ModIface {
- mi_package = ThisPackage, -- to be filled in properly later
+ mi_package = HomePackage, -- to be filled in properly later
mi_module = mod_name,
mi_mod_vers = mod_vers,
mi_boot = False, -- Binary interfaces are never .hi-boot files!
-- of whether they are home-pkg or not
| HomePkg Module OccName Version -- From another module in home package;
- -- has version #
+ -- has version #; in all other respects,
+ -- HomePkg and ExtPkg are the same
| LocalTop OccName -- Top-level from the same module as
-- the enclosing IfaceDecl
import {-# SOURCE #-} TcIface( tcIfaceDecl )
-import Packages ( PackageState(..), isHomeModule )
+import Packages ( PackageState(..), PackageIdH(..), isHomePackage )
import DriverState ( v_GhcMode, isCompManagerMode )
import DriverUtil ( replaceFilenameSuffix )
import CmdLineOpts ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) )
lookupOrig )
import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..),
addEpsInStats, ExternalPackageState(..),
- PackageTypeEnv, emptyTypeEnv, IfacePackage(..),
+ PackageTypeEnv, emptyTypeEnv,
lookupIfaceByModule, emptyPackageIfaceTable,
IsBootInterface, mkIfaceFixCache, Gated,
implicitTyThings, addRulesToPool, addInstsToPool,
import Class ( Class, className )
import TyCon ( tyConName )
import SrcLoc ( mkSrcLoc, importedSrcLoc )
-import Maybes ( isJust, mapCatMaybes )
+import Maybes ( mapCatMaybes, MaybeErr(..) )
import StringBuffer ( hGetStringBuffer )
import FastString ( mkFastString )
import ErrUtils ( Message, mkLocMessage )
import Finder ( findModule, findPackageModule, FindResult(..),
- hiBootExt, hiBootVerExt )
+ hiBootFilePath )
import Lexer
import Outputable
import BinIface ( readBinIface )
-import Panic
+import Panic ( ghcError, tryMost, showException, GhcException(..) )
import List ( nub )
import DATA_IOREF ( readIORef )
= do { mb_iface <- initIfaceTcRn $ loadInterface doc mod_name
(ImportByUser want_boot)
; case mb_iface of
- Left err -> failWithTc (elaborate err)
- Right iface -> return iface
+ Failed err -> failWithTc (elaborate err)
+ Succeeded iface -> return iface
}
where
elaborate err = hang (ptext SLIT("Failed to load interface for") <+>
loadSysInterface doc mod_name
= do { mb_iface <- loadInterface doc mod_name ImportBySystem
; case mb_iface of
- Left err -> ghcError (ProgramError (showSDoc err))
- Right iface -> return iface }
+ Failed err -> ghcError (ProgramError (showSDoc err))
+ Succeeded iface -> return iface }
\end{code}
\begin{code}
loadInterface :: SDoc -> Module -> WhereFrom
- -> IfM lcl (Either Message ModIface)
+ -> IfM lcl (MaybeErr Message ModIface)
-- If it can't find a suitable interface file, we
-- a) modify the PackageIfaceTable to have an empty entry
-- (to avoid repeated complaints)
--
-- It's not necessarily an error for there not to be an interface
-- file -- perhaps the module has changed, and that interface
--- is no longer used -- but the caller can deal with that by
--- catching the exception
+-- is no longer used
-loadInterface doc_str mod_name from
+loadInterface doc_str mod from
= do { -- Read the state
(eps,hpt) <- getEpsAndHpt
- ; traceIf (text "Considering whether to load" <+> ppr mod_name <+> ppr 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_name of {
+ ; case lookupIfaceByModule hpt (eps_PIT eps) mod of {
Just iface
- -> returnM (Right iface) ; -- Already loaded
+ -> returnM (Succeeded iface) ; -- Already loaded
-- The (src_imp == mi_boot iface) test checks that the already-loaded
-- interface isn't a boot iface. This can conceivably happen,
-- if an earlier import had a before we got to real imports. I think.
ImportByUser usr_boot -> usr_boot
ImportBySystem -> sys_boot
- ; mb_dep = lookupModuleEnv (eps_is_boot eps) mod_name
+ ; mb_dep = lookupModuleEnv (eps_is_boot eps) mod
; sys_boot = case mb_dep of
Just (_, is_boot) -> is_boot
Nothing -> False
-- READ THE MODULE IN
; let explicit | ImportByUser _ <- from = True
| otherwise = False
- ; read_result <- findAndReadIface explicit doc_str mod_name hi_boot_file
+ ; read_result <- findAndReadIface explicit doc_str mod hi_boot_file
; dflags <- getDOpts
; case read_result of {
- Left err -> do
- { let fake_iface = emptyModIface ThisPackage mod_name
+ Failed err -> do
+ { let fake_iface = emptyModIface HomePackage mod
; updateEps_ $ \eps ->
eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
-- Not found, so add an empty iface to
-- the EPS map so that we don't look again
- ; returnM (Left err) } ;
+ ; returnM (Failed err) } ;
-- Found and parsed!
- Right iface ->
+ 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
+ -> returnM (Failed (badDepMsg mod))
- let { mod = mi_module iface } in
+ | otherwise ->
- -- Sanity check. If we're system-importing a module we know nothing at all
- -- about, it should be from a different package to this one
- WARN( case from of { ImportBySystem -> True; other -> False } &&
- not (isJust mb_dep) &&
- isHomeModule dflags mod,
- ppr mod $$ ppr mb_dep $$ ppr (eps_is_boot eps) )
+ let
+ loc_doc = text file_path <+> colon
+ in
+ initIfaceLcl mod loc_doc $ do
- initIfaceLcl mod_name $ do
-- Load the new ModIface into the External Package State
-- Even home-package interfaces loaded by loadInterface
-- (which only happens in OneShot mode; in Batch/Interactive
-- If we do loadExport first the wrong info gets into the cache (unless we
-- explicitly tag each export which seems a bit of a bore)
- { ignore_prags <- doptM Opt_IgnoreInterfacePragmas
- ; new_eps_decls <- loadDecls ignore_prags mod (mi_decls iface)
- ; new_eps_rules <- loadRules ignore_prags mod_name (mi_rules iface)
- ; new_eps_insts <- loadInsts mod_name (mi_insts iface)
+ ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas
+ ; new_eps_decls <- mapM (loadDecl ignore_prags) (mi_decls iface)
+ ; new_eps_insts <- mapM loadInst (mi_insts iface)
+ ; new_eps_rules <- if ignore_prags
+ then return []
+ else mapM loadRule (mi_rules iface)
; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT",
mi_insts = panic "No mi_insts in PIT",
eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls)
(length new_eps_insts) (length new_eps_rules) }
- ; return (Right final_iface)
- }}}}}
+ ; return (Succeeded final_iface)
+ }}}}
+
+badDepMsg mod
+ = hang (ptext SLIT("Interface file inconsistency:"))
+ 2 (sep [ptext SLIT("home-package module") <+> quotes (ppr mod) <+> ptext SLIT("is mentioned,"),
+ ptext SLIT("but does not appear in the dependencies of the interface")])
-----------------------------------------------------
-- Loading type/class/value decls
addDeclsToPTE :: PackageTypeEnv -> [[(Name,TyThing)]] -> PackageTypeEnv
addDeclsToPTE pte things = foldl extendNameEnvList pte things
-loadDecls :: Bool -- Don't load pragmas into the decl pool
- -> Module
- -> [(Version, IfaceDecl)]
- -> IfL [[(Name,TyThing)]] -- The list can be poked eagerly, but the
+loadDecl :: Bool -- Don't load pragmas into the decl pool
+ -> (Version, IfaceDecl)
+ -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the
-- TyThings are forkM'd thunks
-loadDecls ignore_prags mod decls = mapM (loadDecl ignore_prags mod) decls
-
-loadDecl ignore_prags mod (_version, decl)
+loadDecl ignore_prags (_version, decl)
= do { -- Populate the name cache with final versions of all
-- the names associated with the decl
- main_name <- mk_new_bndr Nothing (ifName decl)
- ; implicit_names <- mapM (mk_new_bndr (Just main_name)) (ifaceDeclSubBndrs decl)
+ mod <- getIfModule
+ ; main_name <- mk_new_bndr mod Nothing (ifName decl)
+ ; implicit_names <- mapM (mk_new_bndr mod (Just main_name)) (ifaceDeclSubBndrs decl)
-- Typecheck the thing, lazily
; thing <- forkM doc (bumpDeclStats main_name >> tcIfaceDecl stripped_decl)
-- * parent
-- * location
-- imported name, to fix the module correctly in the cache
- mk_new_bndr mb_parent occ = newGlobalBinder mod occ mb_parent loc
- loc = importedSrcLoc (moduleUserString mod)
+ mk_new_bndr mod mb_parent occ
+ = newGlobalBinder mod occ mb_parent
+ (importedSrcLoc (moduleUserString mod))
+
doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
discardDeclPrags :: IfaceDecl -> IfaceDecl
-- Loading instance decls
-----------------------------------------------------
-loadInsts :: Module -> [IfaceInst] -> IfL [(Name, Gated IfaceInst)]
-loadInsts mod decls = mapM (loadInstDecl mod) decls
+loadInst :: IfaceInst -> IfL (Name, Gated IfaceInst)
-loadInstDecl mod decl@(IfaceInst {ifInstHead = inst_ty})
+loadInst decl@(IfaceInst {ifInstHead = inst_ty})
= do {
-- Find out what type constructors and classes are "gates" for the
-- instance declaration. If all these "gates" are slurped in then
let { (cls_ext, tc_exts) = ifaceInstGates inst_ty }
; cls <- lookupIfaceExt cls_ext
; tcs <- mapM lookupIfaceTc tc_exts
- ; returnM (cls, (tcs, (mod,decl)))
+ ; (mod, doc) <- getIfCtxt
+ ; returnM (cls, (tcs, (mod, doc, decl)))
}
-----------------------------------------------------
-- Loading Rules
-----------------------------------------------------
-loadRules :: Bool -- Don't load pragmas into the decl pool
- -> Module
- -> [IfaceRule] -> IfL [Gated IfaceRule]
-loadRules ignore_prags mod rules
- | ignore_prags = returnM []
- | otherwise = mapM (loadRule mod) rules
-
-loadRule :: Module -> IfaceRule -> IfL (Gated IfaceRule)
+loadRule :: IfaceRule -> IfL (Gated IfaceRule)
-- "Gate" the rule simply by a crude notion of the free vars of
-- the LHS. It can be crude, because having too few free vars is safe.
-loadRule mod decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args})
+loadRule decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args})
= do { names <- mapM lookupIfaceExt (fn : arg_fvs)
- ; returnM (names, (mod, decl)) }
+ ; (mod, doc) <- getIfCtxt
+ ; returnM (names, (mod, doc, decl)) }
where
arg_fvs = [n | arg <- args, n <- crudeIfExprGblFvs arg]
-- The lists are always small => appending is fine
get_tcs_s :: [IfaceType] -> [IfaceExtName]
get_tcs_s tys = foldr ((++) . get_tcs) [] tys
+
+
+----------------
+getIfCtxt :: IfL (Module, SDoc)
+getIfCtxt = do { env <- getLclEnv; return (if_mod env, if_loc env) }
\end{code}
-> SDoc -> Module
-> IsBootInterface -- True <=> Look for a .hi-boot file
-- False <=> Look for .hi file
- -> IfM lcl (Either Message ModIface)
+ -> IfM lcl (MaybeErr Message (ModIface, FilePath))
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
-- Check for GHC.Prim, and return its static interface
; dflags <- getDOpts
- ; let base_id = basePackageId (pkgState dflags)
- base_pkg
- | Just id <- base_id = ExternalPackage id
- | otherwise = ThisPackage
- -- if basePackageId is Nothing, it means we must be
- -- compiling the base package.
+ ; let base_pkg = basePackageId (pkgState dflags)
; if mod_name == gHC_PRIM
- then returnM (Right (ghcPrimIface{ mi_package = base_pkg }))
+ then returnM (Succeeded (ghcPrimIface{ mi_package = base_pkg },
+ "<built in interface for GHC.Prim>"))
else do
-- Look for the file
; mb_found <- ioToIOEnv (findHiFile dflags explicit mod_name hi_boot_file)
; case mb_found of {
- Left err -> do
+ Failed err -> do
{ traceIf (ptext SLIT("...not found"))
; dflags <- getDOpts
- ; returnM (Left (noIfaceErr dflags mod_name err)) } ;
+ ; returnM (Failed (noIfaceErr dflags mod_name err)) } ;
- Right (file_path,pkg) -> do
+ Succeeded (file_path, pkg) -> do
-- Found file, so read it
{ traceIf (ptext SLIT("readIFace") <+> text file_path)
; read_result <- readIface mod_name file_path hi_boot_file
; case read_result of
- Left err -> returnM (Left (badIfaceFile file_path err))
- Right iface
+ Failed err -> returnM (Failed (badIfaceFile file_path err))
+ Succeeded iface
| mi_module iface /= mod_name ->
- return (Left (wrongIfaceModErr iface mod_name file_path))
+ return (Failed (wrongIfaceModErr iface mod_name file_path))
| otherwise ->
- returnM (Right iface{mi_package=pkg})
- -- don't forget to fill in the package name...
+ returnM (Succeeded (iface{mi_package=pkg}, file_path))
+ -- Don't forget to fill in the package name...
}}}
findHiFile :: DynFlags -> Bool -> Module -> IsBootInterface
- -> IO (Either FindResult (FilePath, IfacePackage))
+ -> IO (MaybeErr FindResult (FilePath, PackageIdH))
findHiFile dflags explicit mod_name hi_boot_file
= do {
-- In interactive or --make mode, we are *not allowed* to demand-load
then findModule dflags mod_name explicit
else findPackageModule dflags mod_name explicit;
- case maybe_found of {
- Found loc pkg -> foundOk loc hi_boot_file pkg;
- err -> return (Left err) ;
- }}
- where
- foundOk loc hi_boot_file pkg = do { -- Don't need module returned by finder
-
- -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate
- let { hi_path = ml_hi_file loc ;
- hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ;
- hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt
- };
-
- if not hi_boot_file then
- return (Right (hi_path,pkg))
- else do {
- hi_ver_exists <- doesFileExist hi_boot_ver_path ;
- if hi_ver_exists then return (Right (hi_boot_ver_path,pkg))
- else return (Right (hi_boot_path,pkg))
- }}
+ case maybe_found of
+ Found loc pkg
+ | hi_boot_file -> do { hi_boot_path <- hiBootFilePath loc
+ ; return (Succeeded (hi_boot_path, pkg)) }
+ | otherwise -> return (Succeeded (ml_hi_file loc, pkg)) ;
+ err -> return (Failed err)
+ }
\end{code}
@readIface@ tries just the one file.
\begin{code}
readIface :: Module -> String -> IsBootInterface
- -> IfM lcl (Either Message ModIface)
- -- Left err <=> file not found, or unreadable, or illegible
- -- Right iface <=> successfully found and parsed
+ -> IfM lcl (MaybeErr Message ModIface)
+ -- Failed err <=> file not found, or unreadable, or illegible
+ -- Succeeded iface <=> successfully found and parsed
readIface wanted_mod_name file_path is_hi_boot_file
= do { dflags <- getDOpts
| is_hi_boot_file -- Read ascii
= do { res <- tryMost (hGetStringBuffer file_path) ;
case res of {
- Left exn -> return (Left (text (showException exn))) ;
+ Left exn -> return (Failed (text (showException exn))) ;
Right buffer ->
case unP parseIface (mkPState buffer loc dflags) of
- PFailed span err -> return (Left (mkLocMessage span err))
+ PFailed span err -> return (Failed (mkLocMessage span err))
POk _ iface
- | wanted_mod == actual_mod -> return (Right iface)
- | otherwise -> return (Left err)
+ | wanted_mod == actual_mod -> return (Succeeded iface)
+ | otherwise -> return (Failed err)
where
actual_mod = mi_module iface
err = hiModuleNameMismatchWarn wanted_mod actual_mod
| otherwise -- Read binary
= do { res <- tryMost (readBinIface file_path)
; case res of
- Right iface -> return (Right iface)
- Left exn -> return (Left (text (showException exn))) }
+ Right iface -> return (Succeeded iface)
+ Left exn -> return (Failed (text (showException exn))) }
where
loc = mkSrcLoc (mkFastString file_path) 1 0
\end{code}
}
where
mk_gated_rule (fn_name, core_rule)
- = ([fn_name], (nameModule fn_name, IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule))
+ = ([fn_name], (nameModule fn_name, ptext SLIT("<built-in rule>"),
+ IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule))
\end{code}
\begin{code}
ghcPrimIface :: ModIface
ghcPrimIface
- = (emptyModIface ThisPackage gHC_PRIM) {
+ = (emptyModIface HomePackage gHC_PRIM) {
mi_exports = [(gHC_PRIM, ghcPrimExports)],
mi_decls = [],
mi_fixities = fixities,
, ppr read_mod
]
+noIfaceErr :: DynFlags -> Module -> FindResult -> SDoc
noIfaceErr dflags mod_name (PackageHidden pkg)
= ptext SLIT("Could not import") <+> quotes (ppr mod_name) <> colon
$$ ptext SLIT("it is a member of package") <+> ppr pkg <> comma
#include "HsVersions.h"
import HsSyn
-import Packages ( isHomeModule )
+import Packages ( isHomeModule, PackageIdH(..) )
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
IfaceRule(..), IfaceInst(..), IfaceExtName(..), IfaceTyCon(..),
eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool,
import TcRnMonad
import TcRnTypes ( mkModDeps )
import TcType ( isFFITy )
-import HscTypes ( ModIface(..), TyThing(..), IfacePackage(..),
+import HscTypes ( ModIface(..), TyThing(..),
ModGuts(..), ModGuts, IfaceExport,
GhciMode(..), HscEnv(..), hscEPS,
Dependencies(..), FixItem(..),
import DATA_IOREF ( writeIORef )
import Monad ( when )
import List ( insert )
-import Maybes ( orElse, mapCatMaybes, isNothing, isJust, fromJust, expectJust )
+import Maybes ( orElse, mapCatMaybes, isNothing, isJust,
+ fromJust, expectJust, MaybeErr(..) )
\end{code}
; intermediate_iface = ModIface {
mi_module = this_mod,
- mi_package = ThisPackage,
+ mi_package = HomePackage,
mi_boot = False,
mi_deps = deps,
mi_usages = usages,
-- from the .hi file left from the last time we compiled it
readIface this_mod iface_path False `thenM` \ read_result ->
case read_result of {
- Left err -> -- Old interface file not found, or garbled; give up
+ Failed err -> -- Old interface file not found, or garbled; give up
traceIf (text "FYI: cannot read old interface file:"
$$ nest 4 err) `thenM_`
returnM (outOfDate, Nothing)
- ; Right iface ->
+ ; Succeeded iface ->
-- We have got the old iface; check its versions
checkVersions source_unchanged iface `thenM` \ recomp ->
-- Instead, get an Either back which we can test
case mb_iface of {
- Left exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"),
+ Failed exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"),
ppr mod_name]));
-- Couldn't find or parse a module mentioned in the
-- old interface file. Don't complain -- it might just be that
-- the current module doesn't need that import and it's been deleted
- Right iface ->
+ Succeeded iface ->
let
new_mod_vers = mi_mod_vers iface
new_decl_vers = mi_ver_fn iface
, pprDeprecs (mi_deprecs iface)
]
where
- ppr_package ThisPackage = empty
- ppr_package (ExternalPackage id) = doubleQuotes (ftext id)
+ ppr_package HomePackage = empty
+ ppr_package (ExtPackage id) = doubleQuotes (ppr id)
exp_vers = mi_exp_vers iface
rule_vers = mi_rule_vers iface
loadImportedInsts, loadImportedRules,
tcExtCoreBindings
) where
+
#include "HsVersions.h"
import IfaceSyn
-import LoadIface ( loadHomeInterface, predInstGates, discardDeclPrags )
+import LoadIface ( loadHomeInterface, loadInterface, predInstGates, discardDeclPrags )
import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, lookupOrig,
extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
tcIfaceTyVar, tcIfaceLclId,
import Module ( Module )
import UniqSupply ( initUs_ )
import Outputable
+import ErrUtils ( Message )
+import Maybes ( MaybeErr(..) )
import SrcLoc ( noSrcLoc )
import Util ( zipWithEqual, dropList, equalLength, zipLazy )
import CmdLineOpts ( DynFlag(..) )
also turn out to be needed by the code that e2 expands to.
\begin{code}
-tcImportDecl :: Name -> IfG TyThing
+tcImportDecl :: Name -> TcM TyThing
+-- Entry point for source-code uses of importDecl
+tcImportDecl name
+ = do { traceIf (text "tcLookupGlobal" <+> ppr name)
+ ; mb_thing <- initIfaceTcRn (importDecl name)
+ ; case mb_thing of
+ Succeeded thing -> return thing
+ Failed err -> failWithTc err }
+
+importDecl :: Name -> IfM lcl (MaybeErr Message TyThing)
-- Get the TyThing for this Name from an interface file
-tcImportDecl name
+importDecl name
| Just thing <- wiredInNameTyThing_maybe name
-- This case only happens for tuples, because we pre-populate the eps_PTE
-- with other wired-in things. We can't do that for tuples because we
-- don't know how many of them we'll find
= do { updateEps_ (\ eps -> eps { eps_PTE = extendTypeEnv (eps_PTE eps) thing })
- ; return thing }
+ ; return (Succeeded thing) }
| otherwise
= do { traceIf nd_doc
-- Load the interface, which should populate the PTE
- ; loadHomeInterface nd_doc name
+ ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem
+ ; case mb_iface of {
+ Failed err_msg -> return (Failed err_msg) ;
+ Succeeded iface -> do
-- Now look it up again; this time we should find it
- ; eps <- getEps
+ { eps <- getEps
; case lookupTypeEnv (eps_PTE eps) name of
- Just thing -> return thing
- Nothing -> do { ioToIOEnv (printErrs (msg defaultErrStyle)); failM }
- -- Declaration not found!
- -- No errors-var to accumulate errors in, so just
- -- print out the error right now
- }
+ Just thing -> return (Succeeded thing)
+ Nothing -> return (Failed not_found_msg)
+ }}}
where
nd_doc = ptext SLIT("Need decl for") <+> ppr name
- msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
- 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
- ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
+ not_found_msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
+ 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
+ ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
\end{code}
%************************************************************************
do { eps <- getEps; return (eps_inst_env eps) }
else do
{ traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys,
- nest 2 (vcat (map ppr iface_insts))])
+ nest 2 (vcat [ppr i | (_,_,i) <- iface_insts])])
-- Typecheck the new instances
; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts)
where
wired_doc = ptext SLIT("Need home inteface for wired-in thing")
-tc_inst (mod, inst) = initIfaceLcl mod (tcIfaceInst inst)
+tc_inst (mod, loc, inst) = initIfaceLcl mod full_loc (tcIfaceInst inst)
+ where
+ full_loc = loc $$ (nest 2 (ptext SLIT("instance decl") <+> ppr inst))
tcIfaceInst :: IfaceInst -> IfL DFunId
tcIfaceInst (IfaceInst { ifDFun = dfun_occ })
= tcIfaceExtId (LocalTop dfun_occ)
-selectInsts :: Name -> [Name] -> ExternalPackageState -> (ExternalPackageState, [(Module, IfaceInst)])
+selectInsts :: Name -> [Name] -> ExternalPackageState
+ -> (ExternalPackageState, [(Module, SDoc, IfaceInst)])
selectInsts cls tycons eps
= (eps { eps_insts = insts', eps_stats = stats' }, iface_insts)
where
{ -- Get new rules
if_rules <- updateEps selectRules
- ; traceIf (ptext SLIT("Importing rules:") <+> vcat (map ppr if_rules))
+ ; traceIf (ptext SLIT("Importing rules:") <+> vcat [ppr r | (_,_,r) <- if_rules])
- ; let tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule)
; core_rules <- mapM tc_rule if_rules
-- Debug print
; return core_rules
}
-
-selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, IfaceRule)])
+tc_rule (mod, loc, rule) = initIfaceLcl mod full_loc (tcIfaceRule rule)
+ where
+ full_loc = loc $$ (nest 2 (ptext SLIT("rule") <+> ppr rule))
+
+selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, SDoc, IfaceRule)])
-- Not terribly efficient. Look at each rule in the pool to see if
-- all its gates are in the type env. If so, take it out of the pool.
-- If not, trim its gates for next time.
\begin{code}
-tcExtCoreBindings :: Module -> [IfaceBinding] -> IfL [CoreBind] -- Used for external core
-tcExtCoreBindings mod [] = return []
-tcExtCoreBindings mod (b:bs) = do_one mod b (tcExtCoreBindings mod bs)
+tcExtCoreBindings :: [IfaceBinding] -> IfL [CoreBind] -- Used for external core
+tcExtCoreBindings [] = return []
+tcExtCoreBindings (b:bs) = do_one b (tcExtCoreBindings bs)
-do_one :: Module -> IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
-do_one mod (IfaceNonRec bndr rhs) thing_inside
+do_one :: IfaceBinding -> IfL [CoreBind] -> IfL [CoreBind]
+do_one (IfaceNonRec bndr rhs) thing_inside
= do { rhs' <- tcIfaceExpr rhs
- ; bndr' <- newExtCoreBndr mod bndr
+ ; bndr' <- newExtCoreBndr bndr
; extendIfaceIdEnv [bndr'] $ do
{ core_binds <- thing_inside
; return (NonRec bndr' rhs' : core_binds) }}
-do_one mod (IfaceRec pairs) thing_inside
- = do { bndrs' <- mappM (newExtCoreBndr mod) bndrs
+do_one (IfaceRec pairs) thing_inside
+ = do { bndrs' <- mappM newExtCoreBndr bndrs
; extendIfaceIdEnv bndrs' $ do
{ rhss' <- mappM tcIfaceExpr rhss
; core_binds <- thing_inside
%************************************************************************
\begin{code}
-tcIfaceGlobal :: Name -> IfM a TyThing
+tcIfaceGlobal :: Name -> IfL TyThing
tcIfaceGlobal name
= do { (eps,hpt) <- getEpsAndHpt
; case lookupType hpt (eps_PTE eps) name of {
Just thing -> return thing ;
- Nothing ->
+ Nothing -> do
- setLclEnv () $ do -- This gets us back to IfG, mainly to
- -- pacify get_type_env; rather untidy
{ env <- getGblEnv
; case if_rec_types env of
Just (mod, get_type_env)
| nameIsLocalOrFrom mod name
-> do -- It's defined in the module being compiled
- { type_env <- get_type_env
+ { type_env <- setLclEnv () get_type_env -- yuk
; case lookupNameEnv type_env name of
Just thing -> return thing
Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
(ppr name $$ ppr type_env) }
- other -> tcImportDecl name -- It's imported; go get it
- }}}
+ other -> do
+
+ { mb_thing <- importDecl name -- It's imported; go get it
+ ; case mb_thing of
+ Failed err -> failIfM err
+ Succeeded thing -> return thing
+ }}}}
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon IfaceIntTc = return intTyCon
-----------------------
-newExtCoreBndr :: Module -> (OccName, IfaceType) -> IfL Id
-newExtCoreBndr mod (occ, ty)
- = do { name <- newGlobalBinder mod occ Nothing noSrcLoc
+newExtCoreBndr :: (OccName, IfaceType) -> IfL Id
+newExtCoreBndr (occ, ty)
+ = do { mod <- getIfModule
+ ; name <- newGlobalBinder mod occ Nothing noSrcLoc
; ty' <- tcIfaceType ty
; return (mkLocalId name ty') }
-- we need the #includes from the rts package for the stub files
let rtsid = rtsPackageId (pkgState dflags)
rts_includes
- | Just pid <- rtsid =
+ | ExtPackage pid <- rtsid =
let rts_pkg = getPackageDetails (pkgState dflags) pid in
concatMap mk_include (includes rts_pkg)
| otherwise = []
-----------------------------------------------------------------------------
--- $Id: DriverMkDepend.hs,v 1.35 2005/01/14 17:57:46 simonmar Exp $
+-- $Id: DriverMkDepend.hs,v 1.36 2005/01/18 12:18:28 simonpj Exp $
--
-- GHC Driver
--
#include "HsVersions.h"
-import HscTypes ( IfacePackage(..) )
import GetImports ( getImportsFromFile )
import CmdLineOpts ( DynFlags )
import DriverState
import DriverUtil
import DriverFlags
+import Packages ( PackageIdH(..) )
import SysTools ( newTempName )
import qualified SysTools
import Module ( Module, ModLocation(..), moduleUserString)
case r of
Found loc pkg
-- not in this package: we don't need a dependency
- | ExternalPackage _ <- pkg, not include_prelude
+ | ExtPackage _ <- pkg, not include_prelude
-> return Nothing
-- normal import: just depend on the .hi file
preprocess :: DynFlags -> FilePath -> IO FilePath
preprocess dflags filename =
- ASSERT(isHaskellSrcFilename filename)
+ ASSERT2(isHaskellSrcFilename filename, text filename)
do runPipeline (StopBefore Hsc) dflags ("preprocess")
False{-temporary output file-}
Nothing{-no specific output file-}
extra_ld_opts <- getStaticOpts v_Opt_l
let pstate = pkgState dflags
- rts_id | Just id <- rtsPackageId pstate = id
+ rts_id | ExtPackage id <- rtsPackageId pstate = id
| otherwise = panic "staticLink: rts package missing"
- base_id | Just id <- basePackageId pstate = id
+ base_id | ExtPackage id <- basePackageId pstate = id
| otherwise = panic "staticLink: base package missing"
rts_pkg = getPackageDetails pstate rts_id
base_pkg = getPackageDetails pstate base_id
extra_ld_opts <- getStaticOpts v_Opt_dll
let pstate = pkgState dflags
- rts_id | Just id <- rtsPackageId pstate = id
+ rts_id | ExtPackage id <- rtsPackageId pstate = id
| otherwise = panic "staticLink: rts package missing"
- base_id | Just id <- basePackageId pstate = id
+ base_id | ExtPackage id <- basePackageId pstate = id
| otherwise = panic "staticLink: base package missing"
rts_pkg = getPackageDetails pstate rts_id
base_pkg = getPackageDetails pstate base_id
mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation
findLinkable, -- :: ModuleName -> ModLocation -> IO (Maybe Linkable)
+ hiBootFilePath, -- :: ModLocation -> IO FilePath
hiBootExt, -- :: String
hiBootVerExt, -- :: String
import Module
import UniqFM ( filterUFM )
-import HscTypes ( Linkable(..), Unlinked(..), IfacePackage(..) )
+import HscTypes ( Linkable(..), Unlinked(..) )
import Packages
import DriverState
import DriverUtil
-- that module: its source file, .hi file, object file, etc.
data FindResult
- = Found ModLocation IfacePackage
+ = Found ModLocation PackageIdH
-- the module was found
| PackageHidden PackageId
-- for an explicit source import: the package containing the module is
| Just err <- visible explicit maybe_pkg -> return err
| otherwise -> return (Found loc (pkgInfoToId maybe_pkg))
-pkgInfoToId :: Maybe (PackageConfig,Bool) -> IfacePackage
-pkgInfoToId (Just (pkg,_)) = ExternalPackage (mkPackageId (package pkg))
-pkgInfoToId Nothing = ThisPackage
+pkgInfoToId :: Maybe (PackageConfig,Bool) -> PackageIdH
+pkgInfoToId (Just (pkg,_)) = ExtPackage (mkPackageId (package pkg))
+pkgInfoToId Nothing = HomePackage
-- Is a module visible or not? Returns Nothing if the import is ok,
-- or Just err if there's a visibility error.
-- basename == dots_to_slashes (moduleNameUserString mod)
loc <- hiOnlyModLocation path basename hisuf
addToFinderCache mod (loc, Nothing)
- return (Found loc ThisPackage)
+ return (Found loc HomePackage)
mkPackageModLocation pkg_info hisuf mod path basename _ext = do
-- basename == dots_to_slashes (moduleNameUserString mod)
mkHomeModLocationSearched mod path basename ext = do
loc <- mkHomeModLocation' mod (path ++ '/':basename) ext
- return (Found loc ThisPackage)
+ return (Found loc HomePackage)
mkHomeModLocation' mod src_basename ext = do
let mod_basename = dots_to_slashes (moduleUserString mod)
return (hi_basename ++ '.':hisuf)
+
+--------------------
+hiBootFilePath :: ModLocation -> IO FilePath
+-- Return Foo.hi-boot, or Foo.hi-boot-n, as appropriate
+hiBootFilePath (ModLocation { ml_hi_file = hi_path })
+ = do { hi_ver_exists <- doesFileExist hi_boot_ver_path
+ ; if hi_ver_exists then return hi_boot_ver_path
+ else return hi_boot_path }
+ where
+ hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ;
+ hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt
+
+
-- -----------------------------------------------------------------------------
-- findLinkable isn't related to the other stuff in here,
-- but there's no other obvious place for it
ModGuts(..), ModImports(..), ForeignStubs(..),
HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
+ hptInstances, hptRules,
ExternalPackageState(..), EpsStats(..), addEpsInStats,
PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
icPrintUnqual, unQualInScope,
ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
- IfacePackage(..), emptyIfaceDepCache,
+ emptyIfaceDepCache,
Deprecs(..), IfaceDeprecs,
import Class ( Class, classSelIds, classTyCon )
import TyCon ( TyCon, tyConSelIds, tyConDataCons )
import DataCon ( dataConImplicitIds )
-import Packages ( PackageId )
+import Packages ( PackageIdH, PackageId )
import CmdLineOpts ( DynFlags )
import BasicTypes ( Version, initialVersion, IPName,
import FiniteMap ( FiniteMap )
import CoreSyn ( IdCoreRule )
-import Maybes ( orElse )
+import Maybes ( orElse, fromJust )
import Outputable
import SrcLoc ( SrcSpan )
import UniqSupply ( UniqSupply )
-- hsc_HPT is not mutable because we only demand-load
-- external packages; the home package is eagerly
-- loaded, module by module, by the compilation manager.
+ --
+ -- The HPT may contain modules compiled earlier by --make
+ -- but not actually below the current module in the dependency
+ -- graph. (This changes a previous invariant: changed Jan 05.)
-- The next two are side-effected by compiling
-- to reflect sucking in interface files
Nothing -> lookupModuleEnv pit mod
\end{code}
+
+\begin{code}
+hptInstances :: HscEnv -> [(Module, IsBootInterface)] -> [DFunId]
+-- Find all the instance declarations that are in modules imported
+-- by this one, directly or indirectly, and are in the Home Package Table
+-- This ensures that we don't see instances from modules --make compiled
+-- before this one, but which are not below this one
+hptInstances hsc_env deps
+ | isOneShot (hsc_mode hsc_env) = [] -- In one-shot mode, the HPT is empty
+ | otherwise
+ = let
+ hpt = hsc_HPT hsc_env
+ in
+ [ dfun
+ | -- Find each non-hi-boot module below me
+ (mod, False) <- deps
+
+ -- Look it up in the HPT
+ , let mod_info = ASSERT2( mod `elemModuleEnv` hpt, ppr mod $$ vcat (map ppr_hm (moduleEnvElts hpt)))
+ fromJust (lookupModuleEnv hpt mod)
+
+ -- And get its dfuns
+ , dfun <- md_insts (hm_details mod_info) ]
+ where
+ ppr_hm hm = ppr (mi_module (hm_iface hm))
+
+hptRules :: HscEnv -> [(Module, IsBootInterface)] -> [IdCoreRule]
+-- Get rules from modules "below" this one (in the dependency sense)
+-- C.f Inst.hptInstances
+hptRules hsc_env deps
+ | isOneShot (hsc_mode hsc_env) = []
+ | otherwise
+ = let
+ hpt = hsc_HPT hsc_env
+ in
+ [ rule
+ | -- Find each non-hi-boot module below me
+ (mod, False) <- deps
+
+ -- Look it up in the HPT
+ , let mod_info = ASSERT( mod `elemModuleEnv` hpt )
+ fromJust (lookupModuleEnv hpt mod)
+
+ -- And get its dfuns
+ , rule <- md_rules (hm_details mod_info) ]
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Symbol tables and Module details}
\begin{code}
data ModIface
= ModIface {
- mi_package :: !IfacePackage, -- Which package the module comes from
+ mi_package :: !PackageIdH, -- Which package the module comes from
mi_module :: !Module,
mi_mod_vers :: !Version, -- Module version: changes when anything changes
-- seeing if we are up to date wrt the old interface
}
-data IfacePackage = ThisPackage | ExternalPackage PackageId
-
-- Should be able to construct ModDetails from mi_decls in ModIface
data ModDetails
= ModDetails {
\end{code}
\begin{code}
-emptyModIface :: IfacePackage -> Module -> ModIface
+emptyModIface :: PackageIdH -> Module -> ModIface
emptyModIface pkg mod
= ModIface { mi_package = pkg,
mi_module = mod,
\end{code}
\begin{code}
-type Gated d = ([Name], (Module, d)) -- The [Name] 'gate' the declaration; always non-empty
- -- Module records which iface file this
- -- decl came from
+type Gated d = ([Name], (Module, SDoc, d))
+ -- The [Name] 'gate' the declaration; always non-empty
+ -- Module records which module this decl belongs to
+ -- SDoc records the pathname of the file, or similar err-ctxt info
type RulePool = [Gated IfaceRule]
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.141 2004/11/26 16:21:00 simonmar Exp $
+-- $Id: Main.hs,v 1.142 2005/01/18 12:18:34 simonpj Exp $
--
-- GHC Driver program
--
import HscTypes ( GhciMode(..) )
import Config ( cBooterVersion, cGhcUnregisterised, cProjectVersion )
import SysTools ( initSysTools, cleanTempFiles, normalisePath )
-import Packages ( dumpPackages, initPackages, haskell98PackageId )
+import Packages ( dumpPackages, initPackages, haskell98PackageId, PackageIdH(..) )
import DriverPipeline ( staticLink, doMkDLL, runPipeline )
import DriverState ( buildStgToDo,
findBuildTag, unregFlags,
-- Always link in the haskell98 package for static linking. Other
-- packages have to be specified via the -package flag.
let link_pkgs
- | Just h98_id <- haskell98PackageId (pkgState dflags) = [h98_id]
+ | ExtPackage h98_id <- haskell98PackageId (pkgState dflags) = [h98_id]
| otherwise = []
case mode of
-- * PackageId
PackageId,
mkPackageId, stringToPackageId, packageIdString, packageConfigId,
+ packageIdFS, fsToPackageId,
-- * The PackageConfig type: information about a package
PackageConfig,
--
-- A PackageId is a string of the form <pkg>-<version>.
-type PackageId = FastString -- includes the version
+newtype PackageId = PId FastString deriving( Eq, Ord ) -- includes the version
-- easier not to use a newtype here, because we need instances of
-- Binary & Outputable, and we're too early to define them
+fsToPackageId :: FastString -> PackageId
+fsToPackageId = PId
+
+packageIdFS :: PackageId -> FastString
+packageIdFS (PId fs) = fs
+
stringToPackageId :: String -> PackageId
-stringToPackageId = mkFastString
+stringToPackageId = fsToPackageId . mkFastString
+
+packageIdString :: PackageId -> String
+packageIdString = unpackFS . packageIdFS
mkPackageId :: PackageIdentifier -> PackageId
mkPackageId = stringToPackageId . showPackageId
packageConfigId :: PackageConfig -> PackageId
packageConfigId = mkPackageId . package
-packageIdString :: PackageId -> String
-packageIdString = unpackFS
+
extendPackageConfigMap, dumpPackages,
-- * Reading the package config, and processing cmdline args
- PackageState(..),
+ PackageIdH(..), isHomePackage,
+ PackageState(..),
initPackages,
moduleToPackageConfig,
getPackageDetails,
-- exposed is True if the package exposes that module.
-- The PackageIds of some known packages
- basePackageId :: Maybe PackageId,
- rtsPackageId :: Maybe PackageId,
- haskell98PackageId :: Maybe PackageId,
- thPackageId :: Maybe PackageId
+ basePackageId :: PackageIdH,
+ rtsPackageId :: PackageIdH,
+ haskell98PackageId :: PackageIdH,
+ thPackageId :: PackageIdH
}
+data PackageIdH
+ = HomePackage -- The "home" package is the package curently
+ -- being compiled
+ | ExtPackage PackageId -- An "external" package is any other package
+
+
+isHomePackage :: PackageIdH -> Bool
+isHomePackage HomePackage = True
+isHomePackage (ExtPackage _) = False
+
-- A PackageConfigMap maps a PackageId to a PackageConfig
type PackageConfigMap = UniqFM PackageConfig
-- Look up some known PackageIds
--
let
+ lookupPackageByName :: FastString -> PackageIdH
lookupPackageByName nm =
case [ conf | p <- dep_exposed,
Just conf <- [lookupPackage pkg_db p],
nm == mkFastString (pkgName (package conf)) ] of
- [] -> Nothing
- (p:ps) -> Just (mkPackageId (package p))
+ [] -> HomePackage
+ (p:ps) -> ExtPackage (mkPackageId (package p))
-- Get the PackageIds for some known packages (we know the names,
-- but we don't know the versions). Some of these packages might
-- add base & rts to the explicit packages
basicLinkedPackages = [basePackageId,rtsPackageId]
explicit' = addListToUniqSet explicit
- [ p | Just p <- basicLinkedPackages ]
+ [ p | ExtPackage p <- basicLinkedPackages ]
--
-- Close the explicit packages with their dependencies
--
iface :: { ModIface }
: 'module' modid 'where' ifacebody { mkBootIface (unLoc $2) $4 }
-ifacebody :: { [HsDecl RdrName] }
- : '{' ifacedecls '}' { $2 }
- | vocurly ifacedecls close { $2 }
-
-ifacedecls :: { [HsDecl RdrName] }
- : ifacedecl ';' ifacedecls { $1 : $3 }
- | ';' ifacedecls { $2 }
+ifacebody :: { ([(Module, IsBootInterface)], [HsDecl RdrName]) }
+ : '{' ifacetop '}' { $2 }
+ | vocurly ifacetop close { $2 }
+
+ifacetop :: { ([(Module, IsBootInterface)], [HsDecl RdrName]) }
+ : ifaceimps { ($1,[]) }
+ | ifaceimps ';' ifacedecls { ($1,$3) }
+ | ifacedecls { ([],$1) }
+
+ifaceimps :: { [(Module, IsBootInterface)] } -- Reversed, but that's ok
+ : ifaceimps ';' ifaceimp { $3 : $1 }
+ | ifaceimp { [$1] }
+
+ifaceimp :: { (Module, IsBootInterface) }
+ : 'import' maybe_src modid { (unLoc $3, $2) }
+
+-- The defn of iface decls allows a trailing ';', which the lexer geneates for
+-- module Foo where
+-- foo :: ()
+ifacedecls :: { [HsDecl RdrName] } -- Reversed, but doesn't matter
+ : ifacedecls ';' ifacedecl { $3 : $1 }
+ | ifacedecls ';' { $1 }
| ifacedecl { [$1] }
- | {- empty -} { [] }
ifacedecl :: { HsDecl RdrName }
: var '::' sigtype
import HsSyn -- Lots of it
import IfaceType
+import Packages ( PackageIdH(..) )
import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache,
- IfacePackage(..) )
+ Dependencies(..), IsBootInterface, noDependencies )
import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) )
import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
\begin{code}
-mkBootIface :: Module -> [HsDecl RdrName] -> ModIface
+mkBootIface :: Module -> ([(Module, IsBootInterface)], [HsDecl RdrName]) -> ModIface
-- Make the ModIface for a hi-boot file
-- The decls are of very limited form
-- The package will be filled in later (see LoadIface.readIface)
-mkBootIface mod decls
- = (emptyModIface ThisPackage{-fill in later-} mod) {
+mkBootIface mod (imports, decls)
+ = (emptyModIface HomePackage{-fill in later-} mod) {
mi_boot = True,
+ mi_deps = noDependencies { dep_mods = imports },
mi_exports = [(mod, map mk_export decls')],
mi_decls = decls_w_vers,
mi_ver_fn = mkIfaceVerCache decls_w_vers }
hsStrictMark HsUnbox = MarkedUnboxed
hsIfaceName rdr_name -- Qualify unqualifed occurrences
- -- with the module name
+ -- with the module name
| isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
| otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
IfaceExport, HomePackageTable, PackageIfaceTable,
availNames, unQualInScope,
Deprecs(..), ModIface(..), Dependencies(..),
- lookupIface, ExternalPackageState(..),
- IfacePackage(..)
+ lookupIface, ExternalPackageState(..)
)
+import Packages ( PackageIdH(..) )
import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace,
GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
emptyGlobalRdrEnv, plusGlobalRdrEnv, globalRdrEnvElts,
(dependent_mods, dependent_pkgs)
= case mi_package iface of
- ThisPackage ->
+ HomePackage ->
-- Imported module is from the home package
-- Take its dependent modules and add imp_mod itself
-- Take its dependent packages unchanged
-- check. See LoadIface.loadHiBootInterface
((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps)
- ExternalPackage pkg ->
+ ExtPackage pkg ->
-- Imported module is from another package
-- Dump the dependent modules
-- Add the package imp_mod comes from to the dependent packages
import CoreSyn
import TcIface ( loadImportedRules )
import HscTypes ( HscEnv(..), ModGuts(..), ExternalPackageState(..),
- ModDetails(..), HomeModInfo(..), hscEPS )
+ ModDetails(..), HomeModInfo(..), HomePackageTable, Dependencies( dep_mods ),
+ hscEPS, hptRules )
import CSE ( cseProgram )
import Rules ( RuleBase, ruleBaseIds, emptyRuleBase,
extendRuleBaseList, pprRuleBase, ruleCheckProgram )
-import Module ( moduleEnvElts )
+import Module ( elemModuleEnv, lookupModuleEnv )
import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules )
import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
import CoreUtils ( coreBindsSize )
import IO ( hPutStr, stderr )
import Outputable
import List ( partition )
-import Maybes ( orElse )
+import Maybes ( orElse, fromJust )
\end{code}
%************************************************************************
-- (b) Rules are now just orphan rules
prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
- guts@(ModGuts { mg_binds = binds, mg_rules = local_rules })
+ guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })
us
= do { eps <- hscEPS hsc_env
local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
env = setInScopeSet gentleSimplEnv local_ids
(better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
+ home_pkg_rules = hptRules hsc_env (dep_mods deps)
(orphan_rules, rules_for_locals) = partition isOrphanRule better_rules
-- Get the rules for locally-defined Ids out of the RuleBase
-- rules for Ids in this module; if there is, the above bad things may happen
pkg_rule_base = eps_rule_base eps
- hpt_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
+ hpt_rule_base = extendRuleBaseList pkg_rule_base home_pkg_rules
imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules
-- Update the binders in the local bindings with the lcoal rules
#endif
; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
}
- where
- add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
updateBinders rule_base binds
instLoc, getDictClassTys, dictPred,
lookupInst, LookupInstResult(..),
- tcExtendLocalInstEnv, tcGetInstEnvs,
+ tcExtendLocalInstEnv, tcGetInstEnvs,
isDict, isClassDict, isMethod,
isLinearInst, linearInstType, isIPDict, isInheritableInst,
import Unify ( tcMatchTys )
import Kind ( isSubKind )
import Packages ( isHomeModule )
-import HscTypes ( ExternalPackageState(..) )
+import HscTypes ( HscEnv( hsc_HPT ), ExternalPackageState(..),
+ ModDetails( md_insts ), HomeModInfo( hm_details ) )
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName )
import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
import Var ( TyVar, tyVarKind, setIdType )
import VarEnv ( TidyEnv, emptyTidyEnv )
import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
+import Module ( moduleEnvElts, elemModuleEnv, lookupModuleEnv )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
import CmdLineOpts( DynFlags )
-import Maybes ( isJust )
+import Maybes ( isJust, fromJust )
import Outputable
\end{code}
where
loc = getSrcLoc dfun
\end{code}
+
%************************************************************************
%* *
import HsSyn ( LRuleDecl, LHsBinds, LSig, pprLHsBinds )
import TcIface ( tcImportDecl )
import TcRnMonad
-import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV )
+import TcMType ( zonkTcType, zonkTcTyVarsAndFV )
import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType,
tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy,
- tidyOpenType, tidyOpenTyVar, pprTyThingCategory
+ tidyOpenType, pprTyThingCategory
)
import qualified Type ( getTyVar_maybe )
import Id ( idName, isLocalId )
{ (eps,hpt) <- getEpsAndHpt
; case lookupType hpt (eps_PTE eps) name of
Just thing -> return thing
- Nothing -> do { traceIf (text "tcLookupGlobal" <+> ppr name)
- ; initIfaceTcRn (tcImportDecl name) }
+ Nothing -> tcImportDecl name
}}
\end{code}
import TcRnMonad
import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
import Inst ( showLIE )
+import InstEnv ( extendInstEnvList )
import TcBinds ( tcTopBinds )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv )
import ErrUtils ( Messages, mkDumpDoc, showPass )
import Id ( mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
-import Module ( mkModule, moduleEnvElts )
+import Module ( Module, ModuleEnv, mkModule, moduleEnvElts )
import OccName ( mkVarOcc )
import Name ( Name, isExternalName, getSrcLoc, getOccName )
import NameSet
import SrcLoc ( srcLocSpan, Located(..), noLoc )
import Outputable
import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
- GhciMode(..), noDependencies,
+ GhciMode(..), IsBootInterface, noDependencies,
Deprecs( NoDeprecs ), plusDeprecs,
ForeignStubs(NoStubs), TyThing(..),
- TypeEnv, lookupTypeEnv,
+ TypeEnv, lookupTypeEnv, hptInstances,
extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
emptyFixityEnv
)
-- Record boot-file info in the EPS, so that it's
-- visible to loadHiBootInterface in tcRnSrcDecls,
-- and any other incrementally-performed imports
- updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ;
+ let { dep_mods :: ModuleEnv (Module, IsBootInterface)
+ ; dep_mods = imp_dep_mods imports } ;
+
+ updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
-- Update the gbl env
- updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
- tcg_imports = tcg_imports gbl `plusImportAvails` imports })
- $ do {
+ let { home_insts = hptInstances hsc_env (moduleEnvElts dep_mods) } ;
+ updGblEnv ( \ gbl ->
+ gbl { tcg_rdr_env = rdr_env,
+ tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
+ tcg_imports = tcg_imports gbl `plusImportAvails` imports })
+ $ do {
+
traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
-- Fail if there are any errors so far
-- The error printing (if needed) takes advantage
setGblEnv tcg_env $ do {
-- Now the core bindings
- core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ;
+ core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
-- Wrap up
let {
import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..),
TyThing, TypeEnv, emptyTypeEnv,
ExternalPackageState(..), HomePackageTable,
- ModDetails(..), HomeModInfo(..),
Deprecs(..), FixityEnv, FixItem,
GhciMode, lookupType, unQualInScope )
-import Module ( Module, unitModuleEnv, foldModuleEnv )
+import Module ( Module, unitModuleEnv )
import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv,
LocalRdrEnv, emptyLocalRdrEnv )
import Name ( Name, isInternalName )
import Type ( Type )
import NameEnv ( extendNameEnvList )
-import InstEnv ( InstEnv, emptyInstEnv, extendInstEnvList )
+import InstEnv ( emptyInstEnv )
import VarSet ( emptyVarSet )
import VarEnv ( TidyEnv, emptyTidyEnv, emptyVarEnv )
tcg_default = Nothing,
tcg_type_env = emptyNameEnv,
tcg_type_env_var = type_env_var,
- tcg_inst_env = mkHomePackageInstEnv hsc_env,
+ tcg_inst_env = emptyInstEnv,
tcg_inst_uses = dfuns_var,
tcg_th_used = th_var,
tcg_exports = emptyNameSet,
printErrorsAndWarnings msgs
return res
-mkHomePackageInstEnv :: HscEnv -> InstEnv
--- At the moment we (wrongly) build an instance environment from all the
--- home-package modules we have already compiled.
--- We should really only get instances from modules below us in the
--- module import tree.
-mkHomePackageInstEnv (HscEnv {hsc_HPT = hpt})
- = foldModuleEnv (add . md_insts . hm_details) emptyInstEnv hpt
- where
- add dfuns inst_env = extendInstEnvList inst_env dfuns
-
-- mkImpTypeEnv makes the imported symbol table
mkImpTypeEnv :: ExternalPackageState -> HomePackageTable
-> Name -> Maybe TyThing
%************************************************************************
\begin{code}
+mkIfLclEnv :: Module -> SDoc -> IfLclEnv
+mkIfLclEnv mod loc = IfLclEnv { if_mod = mod,
+ if_loc = loc,
+ if_tv_env = emptyOccEnv,
+ if_id_env = emptyOccEnv }
+
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn thing_inside
= do { tcg_env <- getGblEnv
- ; let { if_env = IfGblEnv {
- if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
+ ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
; get_type_env = readMutVar (tcg_type_env_var tcg_env) }
; setEnvs (if_env, ()) thing_inside }
initIfaceExtCore thing_inside
= do { tcg_env <- getGblEnv
; let { mod = tcg_mod tcg_env
+ ; doc = ptext SLIT("External Core file for") <+> quotes (ppr mod)
; if_env = IfGblEnv {
if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
- ; if_lenv = IfLclEnv { if_mod = mod,
- if_tv_env = emptyOccEnv,
- if_id_env = emptyOccEnv }
+ ; if_lenv = mkIfLclEnv mod doc
}
; setEnvs (if_env, if_lenv) thing_inside }
-- Used when checking the up-to-date-ness of the old Iface
-- Initialise the environment with no useful info at all
initIfaceCheck hsc_env do_this
- = do { let { gbl_env = IfGblEnv { if_rec_types = Nothing } ;
- }
+ = do { let gbl_env = IfGblEnv { if_rec_types = Nothing }
; initTcRnIf 'i' hsc_env gbl_env () do_this
}
initIfaceTc hsc_env iface do_this
= do { tc_env_var <- newIORef emptyTypeEnv
; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
- ; if_lenv = IfLclEnv { if_mod = mod,
- if_tv_env = emptyOccEnv,
- if_id_env = emptyOccEnv }
+ ; if_lenv = mkIfLclEnv mod doc
}
; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var)
}
where
mod = mi_module iface
+ doc = ptext SLIT("The interface for") <+> quotes (ppr mod)
initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
-- Used when sucking in new Rules in SimplCore
; initTcRnIf 'i' hsc_env gbl_env () do_this
}
-initIfaceLcl :: Module -> IfL a -> IfM lcl a
-initIfaceLcl mod thing_inside
- = setLclEnv (IfLclEnv { if_mod = mod,
- if_tv_env = emptyOccEnv,
- if_id_env = emptyOccEnv })
- thing_inside
+initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
+initIfaceLcl mod loc_doc thing_inside
+ = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
+
+getIfModule :: IfL Module
+getIfModule = do { env <- getLclEnv; return (if_mod env) }
+--------------------
+failIfM :: Message -> IfL a
+-- The Iface monad doesn't have a place to accumulate errors, so we
+-- just fall over fast if one happens; it "shouldnt happen".
+-- We use IfL here so that we can get context info out of the local env
+failIfM msg
+ = do { env <- getLclEnv
+ ; let full_msg = if_loc env $$ nest 2 msg
+ ; ioToIOEnv (printErrs (full_msg defaultErrStyle))
+ ; failM }
--------------------
forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
-- The environment types
Env(..),
TcGblEnv(..), TcLclEnv(..),
- IfGblEnv(..), IfLclEnv(..),
+ IfGblEnv(..), IfLclEnv(..),
-- Ranamer types
ErrCtxt,
-- it means M.f = \x -> x, where M is the if_mod
if_mod :: Module,
+ -- The field is used only for error reporting
+ -- if (say) there's a Lint error in it
+ if_loc :: SDoc,
+ -- Where the interface came from:
+ -- .hi file, or GHCi state, or ext core
+ -- plus which bit is currently being examined
+
if_tv_env :: OccEnv TyVar, -- Nested tyvar bindings
if_id_env :: OccEnv Id -- Nested id binding
}
{ (eps,hpt) <- getEpsAndHpt
; case lookupType hpt (eps_PTE eps) name of
Just thing -> return (AGlobal thing)
- Nothing -> do { traceIf (text "tcLookupGlobal" <+> ppr name)
- ; thing <- initIfaceTcRn (tcImportDecl name)
+ Nothing -> do { thing <- tcImportDecl name
; return (AGlobal thing) }
-- Imported names should always be findable;
-- if not, we fail hard in tcImportDecl
import Panic
import UniqFM
import FastMutInt
+import PackageConfig ( PackageId, packageIdFS, fsToPackageId )
#if __GLASGOW_HASKELL__ < 503
import DATA_IOREF
(BA ba) <- getByteArray bh (I# l)
return $! (mkFastSubStringBA# ba 0# l)
+instance Binary PackageId where
+ put_ bh pid = put_ bh (packageIdFS pid)
+ get bh = do { fs <- get bh; return (fsToPackageId fs) }
+
instance Binary FastString where
put_ bh f@(FastString id l ba) =
case getUserData bh of {
import {-# SOURCE #-} OccName( OccName )
import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
+import PackageConfig ( PackageId, packageIdString )
import FastString
import qualified Pretty
import Pretty ( Doc, Mode(..) )
instance Outputable FastString where
ppr fs = text (unpackFS fs) -- Prints an unadorned string,
-- no double quotes or anything
+
+instance Outputable PackageId where
+ ppr pid = text (packageIdString pid)
\end{code}
projects / ghc-hetmet.git / commitdiff