Commit 9597206b authored by sof's avatar sof
Browse files

[project @ 1998-04-30 19:14:42 by sof]

Prior to renaming, build up a mapping from module names to
file path of corresponding interface file.
parent 0a263a35
......@@ -948,15 +948,30 @@ findAndReadIface :: SDoc -> Module
-- Just x <=> successfully found and parsed
findAndReadIface doc_str mod_name as_source
= traceRn trace_msg `thenRn_`
getModuleHiMap `thenRn` \ himap ->
case (lookupFM himap real_mod_name) of
Nothing ->
traceRn (ptext SLIT("...failed")) `thenRn_`
returnRn Nothing
Just fpath ->
readIface fpath
{-
getSearchPathRn `thenRn` \ dirs ->
try dirs dirs
try dirs
-}
where
real_mod_name =
case as_source of
HiBootFile -> 'b':moduleString mod_name
HiFile -> moduleString mod_name
trace_msg = sep [hsep [ptext SLIT("Reading"),
case as_source of { HiBootFile -> ptext SLIT("[boot]"); other -> empty},
ptext SLIT("interface for"),
ptext mod_name <> semi],
nest 4 (ptext SLIT("reason:") <+> doc_str)]
{-
-- For import {-# SOURCE #-} Foo, "as_source" will be True
-- and we read Foo.hi-boot, not Foo.hi. This is used to break
-- loops among modules.
......@@ -964,17 +979,18 @@ findAndReadIface doc_str mod_name as_source
HiBootFile -> ".hi-boot" -- Ignore `ways' for boot files.
HiFile -> hi
try all_dirs [] = traceRn (ptext SLIT("...failed")) `thenRn_`
returnRn Nothing
try [] = traceRn (ptext SLIT("...failed")) `thenRn_`
returnRn Nothing
try all_dirs ((dir,hisuf):dirs)
try ((dir,hisuf):dirs)
= readIface file_path `thenRn` \ read_result ->
case read_result of
Nothing -> try all_dirs dirs
Nothing -> try dirs
Just iface -> traceRn (ptext SLIT("...done")) `thenRn_`
returnRn (Just iface)
where
file_path = dir ++ '/' : moduleString mod_name ++ (mod_suffix hisuf)
-}
\end{code}
@readIface@ tries just the one file.
......
......@@ -22,6 +22,7 @@ module RnMonad(
import SST
import GlaExts ( RealWorld, stToIO )
import List ( intersperse )
import HsSyn
import RdrHsSyn
......@@ -30,22 +31,24 @@ import SrcLoc ( noSrcLoc )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
pprBagOfErrors, ErrMsg, WarnMsg
)
import Maybes ( seqMaybe, mapMaybe )
import Name ( Module, Name, OccName, PrintUnqualified, NameSet, emptyNameSet,
isLocallyDefinedName,
modAndOcc, NamedThing(..)
)
import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas )
import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas, opt_WarnHiShadows )
import PrelInfo ( builtinNames )
import TysWiredIn ( boolTyCon )
import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Unique ( Unique )
import UniqFM ( UniqFM )
import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM )
import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM_C )
import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
import UniqSet
import UniqSupply
import Util
import Outputable
import DirUtils ( getDirectoryContents )
infixr 9 `thenRn`, `thenRn_`
\end{code}
......@@ -105,7 +108,7 @@ data Necessity = Compulsory | Optional -- We *must* find definitions for
-- For getting global names
data GDown = GDown
SearchPath
ModuleHiMap
(SSTRWRef Ifaces)
-- For renaming source code
......@@ -130,6 +133,11 @@ data RnSMode = SourceMode -- Renaming source code
type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search
-- for interface files.
type ModuleHiMap = FiniteMap String String
-- mapping from module name to the file path of its corresponding
-- interface file.
type FreeVars = NameSet
\end{code}
......@@ -283,22 +291,22 @@ initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc
-> RnMG r
-> IO (r, Bag ErrMsg, Bag WarnMsg)
initRn mod us dirs loc do_rn
= sstToIO $
newMutVarSST (us, emptyFM, builtins) `thenSST` \ names_var ->
newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var ->
newMutVarSST initOccs `thenSST` \ occs_var ->
let
rn_down = RnDown loc names_var errs_var occs_var
g_down = GDown dirs iface_var
in
initRn mod us dirs loc do_rn = do
names_var <- sstToIO (newMutVarSST (us, emptyFM, builtins))
errs_var <- sstToIO (newMutVarSST (emptyBag,emptyBag))
iface_var <- sstToIO (newMutVarSST (emptyIfaces mod))
occs_var <- sstToIO (newMutVarSST initOccs)
himap <- mkModuleHiMap dirs
let
rn_down = RnDown loc names_var errs_var occs_var
g_down = GDown himap iface_var
-- do the buisness
do_rn rn_down g_down `thenSST` \ res ->
res <- sstToIO (do_rn rn_down g_down)
-- grab errors and return
readMutVarSST errs_var `thenSST` \ (warns,errs) ->
returnSST (res, errs, warns)
(warns, errs) <- sstToIO (readMutVarSST errs_var)
return (res, errs, warns)
initRnMS :: RnEnv -> Module -> RnSMode -> RnMS RealWorld r -> RnMG r
......@@ -324,6 +332,62 @@ initOccs = ([(getName boolTyCon, noSrcLoc)], [])
-- to do as much as possible explicitly.
\end{code}
\begin{code}
mkModuleHiMap :: SearchPath -> IO ModuleHiMap
mkModuleHiMap dirs = do
lss <- mapM (uncurry getAllFilesMatching) dirs
let ls = concat lss
if opt_WarnHiShadows
then return (addListToFM_C conflict env ls)
else return (addListToFM_C (\ old new -> old) env ls)
where
env = emptyFM
conflict old_path new_path
| old_path /= new_path =
pprTrace "Warning: " (text "Identically named interface files present on import path, " $$
text (show old_path) <+> text "shadows" $$
text (show new_path) $$
text "on the import path: " <+>
text (concat (intersperse ":" (map fst dirs))))
old_path
| otherwise = old_path -- don't warn about innocous shadowings.
getAllFilesMatching :: FilePath -> String -> IO [(String, FilePath)]
getAllFilesMatching dir_path suffix = do
fpaths <- getDirectoryContents dir_path
-- fpaths entries do not have dir_path prepended
return (mapMaybe withSuffix fpaths)
where
xiffus = reverse dotted_suffix
dotted_suffix =
case suffix of
[] -> []
('.':xs) -> suffix
ls -> '.':ls
-- filter out files that have the desired suffix
withSuffix nm = go "" xiffus rev_nm `seqMaybe`
go "b" "toob-ih." rev_nm
where
rev_nm = reverse nm
-- the prefix is needed to distinguish between a .hi-boot
-- file and a normal interface file, i.e., I'm not willing
-- to guarantee that the presence of the SOURCE pragma
--
-- import {-# SOURCE #-} Foo (x)
-- import Bar
--
-- will not cause Foo.hi to somehow be looked at when
-- slurping in Bar.
--
go pre [] xs = Just (pre ++ reverse xs, dir_path ++'/':nm)
go _ _ [] = Nothing
go pre (x:xs) (y:ys)
| x == y = go pre xs ys
| otherwise = Nothing
\end{code}
......@@ -697,9 +761,16 @@ setIfacesRn :: Ifaces -> RnMG ()
setIfacesRn ifaces rn_down (GDown dirs iface_var)
= writeMutVarSST iface_var ifaces
{-
getSearchPathRn :: RnMG SearchPath
getSearchPathRn rn_down (GDown dirs iface_var)
= returnSST dirs
-}
getModuleHiMap :: RnMG ModuleHiMap
getModuleHiMap rn_down (GDown himap iface_var)
= returnSST himap
\end{code}
%************************************************************************
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment