-- 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.
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.
import SST
import GlaExts ( RealWorld, stToIO )
+import List ( intersperse )
import HsSyn
import RdrHsSyn
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}
-- For getting global names
data GDown = GDown
- SearchPath
+ ModuleHiMap
(SSTRWRef Ifaces)
-- For 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}
-> 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
-- 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}
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}
%************************************************************************
projects / ghc-hetmet.git / commitdiff