import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual )
-import Name ( OccName, Provenance, Module )
-import OccName ( mkSysModuleFS, mkSysOccFS,
+import Name ( OccName, Provenance )
+import OccName ( mkSysOccFS,
tcName, varName, dataName, clsName, tvName,
- IfaceFlavour, hiFile, hiBootFile,
EncodedFS
)
+import Module ( Module, mkSysModuleFS, IfaceFlavour, hiFile, hiBootFile )
import PrelMods ( mkTupNameStr, mkUbxTupNameStr )
import PrelInfo ( mkTupConRdrName, mkUbxTupConRdrName )
import SrcLoc ( SrcLoc )
-- (c) the IdInfo part of a signature (same reason)
iface_stuff :: { IfaceStuff }
-iface_stuff : iface { PIface $1 }
+iface_stuff : iface { let (nm, iff) = $1 in PIface nm iff }
| type { PType $1 }
| id_info { PIdInfo $1 }
-iface :: { ParsedIface }
-iface : '__interface' mod_name INTEGER checkVersion 'where'
+iface :: { (EncodedFS, ParsedIface) }
+iface : '__interface' mod_fs INTEGER checkVersion 'where'
import_part
instance_import_part
exports_part
instance_decl_part
decls_part
- { ParsedIface
- $2 -- Module name
+ { ( $2 -- Module name
+ , ParsedIface
(fromInteger $3) -- Module version
(reverse $6) -- Usages
(reverse $8) -- Exports
(reverse $7) -- Instance import modules
(reverse $10) -- Decls
(reverse $9) -- Local instances
+ )
}
--------------------------------------------------------------------------
-- Haskell code
{
-data IfaceStuff = PIface ParsedIface
+data IfaceStuff = PIface EncodedFS{-.hi module name-} ParsedIface
| PIdInfo [HsIdInfo RdrName]
| PType RdrNameHsType
import RnEnv ( addImplicitOccsRn, availName, availNames, availsToNameSet,
warnUnusedTopNames
)
+import Module ( pprModule )
import Name ( Name, isLocallyDefined,
NamedThing(..), ImportReason(..), Provenance(..),
- nameModule, pprModule, pprOccName, nameOccName,
+ nameModule, pprOccName, nameOccName,
getNameProvenance, occNameUserString,
)
import RdrName ( RdrName )
import NameSet
import OccName ( OccName,
mkDFunOcc,
- occNameFlavour, moduleIfaceFlavour
+ occNameFlavour
)
+import Module ( moduleIfaceFlavour )
import TyCon ( TyCon )
import FiniteMap
import Unique ( Unique, Uniquable(..), unboundKey )
%*********************************************************
\begin{code}
-newImportedGlobalName :: Module -> OccName
- -> RnM s d Name
+newImportedGlobalName :: Module -> OccName -> RnM s d Name
newImportedGlobalName mod occ
= -- First check the cache
getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
let
key = (mod,occ)
- mod_hif = moduleIfaceFlavour mod
in
case lookupFM cache key of
Nothing -> -- Miss in the cache!
-- Build a new original name, and put it in the cache
getOmitQualFn `thenRn` \ omit_fn ->
+ setModuleFlavourRn mod `thenRn` \ mod' ->
let
(us', us1) = splitUniqSupply us
uniq = uniqFromSupply us1
- name = mkGlobalName uniq mod occ (NonLocalDef ImplicitImport (omit_fn name))
+ name = mkGlobalName uniq mod' occ (NonLocalDef ImplicitImport (omit_fn name))
-- For in-scope things we improve the provenance
-- in RnNames.importsFromImportDecl
new_cache = addToFM cache key name
fmToList
)
import Name ( Name {-instance NamedThing-},
- nameModule, moduleUserString, pprModule, isLocallyDefined,
- isWiredInName, maybeWiredInTyConName, pprModule,
- maybeWiredInIdName, nameUnique, NamedThing(..)
+ nameModule, isLocallyDefined,
+ isWiredInName, maybeWiredInTyConName,
+ maybeWiredInIdName, nameUnique, NamedThing(..),
+ pprEncodedFS
)
-import OccName ( Module, mkBootModule,
- moduleIfaceFlavour, bootFlavour, hiFile
+import Module ( Module, mkBootModule, moduleString, pprModule,
+ mkDynamicModule, moduleIfaceFlavour, bootFlavour, hiFile,
+ moduleUserString, moduleFS, setModuleFlavour
)
import RdrName ( RdrName, rdrNameOcc )
import NameSet
%*********************************************************
\begin{code}
-loadHomeInterface :: SDoc -> Name -> RnMG Ifaces
+loadHomeInterface :: SDoc -> Name -> RnMG (Module, Ifaces)
loadHomeInterface doc_str name
= loadInterface doc_str (nameModule name)
-loadInterface :: SDoc -> Module -> RnMG Ifaces
+loadInterface :: SDoc -> Module -> RnMG (Module, Ifaces)
loadInterface doc_str load_mod
= getIfacesRn `thenRn` \ ifaces ->
let
new_hif = moduleIfaceFlavour load_mod
- this_mod = iMod ifaces
mod_map = iModMap ifaces
(insts, tycls_names) = iDefInsts ifaces
in
| bootFlavour new_hif || not (bootFlavour existing_hif)
-> -- Already in the cache, and new version is no better than old,
-- so don't re-read it
- returnRn ifaces ;
+ returnRn (setModuleFlavour existing_hif load_mod, ifaces) ;
other ->
-- READ THE MODULE IN
new_ifaces = ifaces { iModMap = new_mod_map }
in
setIfacesRn new_ifaces `thenRn_`
- failWithRn new_ifaces (noIfaceErr load_mod) ;
+ failWithRn (load_mod, new_ifaces) (noIfaceErr load_mod) ;
-- Found and parsed!
- Just (ParsedIface _ mod_vers usages exports rd_inst_mods rd_decls rd_insts) ->
+ Just (the_mod, ParsedIface mod_vers usages exports rd_inst_mods rd_decls rd_insts) ->
+
-- LOAD IT INTO Ifaces
-- First set the module
-- explicitly tag each export which seems a bit of a bore)
getModuleRn `thenRn` \ this_mod ->
- setModuleRn load_mod $ -- First set the module name of the module being loaded,
+ setModuleRn the_mod $ -- First set the module name of the module being loaded,
-- so that unqualified occurrences in the interface file
-- get the right qualifer
foldlRn loadDecl (iDecls ifaces) rd_decls `thenRn` \ new_decls ->
mapRn (loadExport this_mod) exports `thenRn` \ avails_s ->
let
- mod_details = (new_hif, mod_vers, concat avails_s)
+ -- Notice: the 'flavour' of the loaded Module does not have to
+ -- be the same as the requested Module.
+ the_mod_hif = moduleIfaceFlavour the_mod
+ mod_details = (the_mod_hif, mod_vers, concat avails_s)
-- Exclude this module from the "special-inst" modules
new_inst_mods = iInstMods ifaces `unionLists` (filter (/= this_mod) rd_inst_mods)
- new_ifaces = ifaces { iModMap = addToFM mod_map load_mod mod_details,
+ new_ifaces = ifaces { iModMap = addToFM mod_map the_mod mod_details,
iDecls = new_decls,
iFixes = new_fixities,
iDefInsts = (new_insts, tycls_names),
iInstMods = new_inst_mods }
in
setIfacesRn new_ifaces `thenRn_`
- returnRn new_ifaces
+ returnRn (the_mod, new_ifaces)
}}
loadExport :: Module -> ExportItem -> RnMG [AvailInfo]
-- but it's a bogus thing to do!
| otherwise
- = mapRn load_entity entities
+ = setModuleFlavourRn mod `thenRn` \ mod' ->
+ mapRn (load_entity mod') entities
where
- new_name occ = newImportedGlobalName mod occ
+ new_name mod occ = newImportedGlobalName mod occ
- load_entity (Avail occ)
- = new_name occ `thenRn` \ name ->
+ load_entity mod (Avail occ)
+ = new_name mod occ `thenRn` \ name ->
returnRn (Avail name)
- load_entity (AvailTC occ occs)
- = new_name occ `thenRn` \ name ->
- mapRn new_name occs `thenRn` \ names ->
+ load_entity mod (AvailTC occ occs)
+ = new_name mod occ `thenRn` \ name ->
+ mapRn (new_name mod) occs `thenRn` \ names ->
returnRn (AvailTC name names)
pprModule mod_name]) `thenRn_`
returnRn False
- Just (ParsedIface _ _ usages _ _ _ _)
+ Just (_, ParsedIface _ usages _ _ _ _)
-> -- Found it, so now check it
checkModUsage usages
where
checkModUsage [] = returnRn True -- Yes! Everything is up to date!
checkModUsage ((mod, old_mod_vers, whats_imported) : rest)
- = loadInterface doc_str mod `thenRn` \ ifaces ->
+ = loadInterface doc_str mod `thenRn` \ (mod, ifaces) ->
let
maybe_new_mod_vers = lookupFM (iModMap ifaces) mod
Just (_, new_mod_vers, _) = maybe_new_mod_vers
getNonWiredInDecl :: Name -> SrcLoc -> RnMode -> RnMG (Maybe RdrNameHsDecl)
getNonWiredInDecl needed_name loc mode
= traceRn doc_str `thenRn_`
- loadHomeInterface doc_str needed_name `thenRn` \ ifaces ->
+ loadHomeInterface doc_str needed_name `thenRn` \ (_, ifaces) ->
case lookupNameEnv (iDecls ifaces) needed_name of
-- Special case for data/newtype type declarations
%*********************************************************
\begin{code}
-getInterfaceExports :: Module -> RnMG Avails
+getInterfaceExports :: Module -> RnMG (Module, Avails)
getInterfaceExports mod
- = loadInterface doc_str mod `thenRn` \ ifaces ->
+ = loadInterface doc_str mod `thenRn` \ (mod, ifaces) ->
case lookupFM (iModMap ifaces) mod of
Nothing -> -- Not there; it must be that the interface file wasn't found;
-- the error will have been reported already.
-- (Actually loadInterface should put the empty export env in there
-- anyway, but this does no harm.)
- returnRn []
+ returnRn (mod, [])
- Just (_, _, avails) -> returnRn avails
+ Just (_, _, avails) -> returnRn (mod, avails)
where
doc_str = sep [pprModule mod, ptext SLIT("is directly imported")]
\end{code}
%*********************************************************
\begin{code}
-findAndReadIface :: SDoc -> Module -> RnMG (Maybe ParsedIface)
+findAndReadIface :: SDoc -> Module -> RnMG (Maybe (Module, ParsedIface))
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
getModuleHiMap from_hi_boot `thenRn` \ himap ->
case (lookupFM himap (moduleUserString mod_name)) of
-- Found the file
- Just fpath -> readIface fpath
+ Just fpath -> readIface mod_name fpath
-- Hack alert! When compiling PrelBase we have to load the
-- decls for packCString# and friends; they are 'thin-air' Ids
-- (see PrelInfo.lhs). So if we don't find the HiFile we quietly
@readIface@ tries just the one file.
\begin{code}
-readIface :: String -> RnMG (Maybe ParsedIface)
+readIface :: Module -> (String, Bool) -> RnMG (Maybe (Module, ParsedIface))
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
-readIface file_path
+readIface requested_mod (file_path, is_dll)
= ioToRnMG (hGetStringBuffer file_path) `thenRn` \ read_result ->
case read_result of
Right contents ->
case parseIface contents (mkSrcLoc (mkFastString file_path) 1) of
- Failed err -> failWithRn Nothing err
- Succeeded (PIface iface) ->
- if opt_D_show_rn_imports then
- putDocRn (hcat[ptext SLIT("Read "), text file_path]) `thenRn_`
- returnRn (Just iface)
- else
- returnRn (Just iface)
-
- Left err ->
- if isDoesNotExistError err then
- returnRn Nothing
- else
- failWithRn Nothing (cannaeReadFile file_path err)
+ Failed err -> failWithRn Nothing err
+ Succeeded (PIface mod_nm iface) ->
+ (if mod_nm /= moduleFS requested_mod then
+ addWarnRn (hsep [ ptext SLIT("Something is amiss; requested module name")
+ , pprModule requested_mod
+ , ptext SLIT("differs from name found in the interface file ")
+ , pprEncodedFS mod_nm
+ ])
+ else
+ returnRn ()) `thenRn_`
+ let
+ the_mod
+ | is_dll = mkDynamicModule requested_mod
+ | otherwise = requested_mod
+ in
+ if opt_D_show_rn_imports then
+ putDocRn (hcat[ptext SLIT("Read module "), pprEncodedFS mod_nm,
+ ptext SLIT(" from "), text file_path]) `thenRn_`
+ returnRn (Just (the_mod, iface))
+ else
+ returnRn (Just (the_mod, iface))
+
+ Left err
+ | isDoesNotExistError err -> returnRn Nothing
+ | otherwise -> failWithRn Nothing (cannaeReadFile file_path err)
+
\end{code}
%*********************************************************
\begin{code}
mkSearchPath :: Maybe String -> SearchPath
-mkSearchPath Nothing = [(".",".hi")]
-mkSearchPath (Just s)
- = go s
+mkSearchPath Nothing = [(".",".hi")] -- ToDo: default should be to look in
+ -- the directory the module we're compiling
+ -- lives.
+mkSearchPath (Just s) = go s
where
go "" = []
go s =
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
pprBagOfErrors, ErrMsg, WarnMsg, Message
)
-import Name ( Module, Name, OccName, NamedThing(..), IfaceFlavour,
- isLocallyDefinedName, nameModule, nameOccName
+import Name ( Name, OccName, NamedThing(..),
+ isLocallyDefinedName, nameModule, nameOccName,
+ decode
+ )
+import Module ( Module, IfaceFlavour, setModuleFlavour, mkSysModuleFS,
+ bootFlavour, moduleString, moduleIfaceFlavour, mkDynFlavour
)
import NameSet
import RdrName ( RdrName )
-import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas, opt_WarnHiShadows )
+import CmdLineOpts ( opt_D_show_rn_trace, opt_IgnoreIfacePragmas,
+ opt_WarnHiShadows, opt_Static
+ )
import PrelInfo ( builtinNames )
import TysWiredIn ( boolTyCon )
import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Util
import Outputable
import DirUtils ( getDirectoryContents )
+import Directory ( doesFileExist )
import IO ( hPutStrLn, stderr, isDoesNotExistError )
import Monad ( foldM )
import Maybe ( fromMaybe )
rn_ns :: SSTRef s RnNameSupply,
rn_errs :: SSTRef s (Bag WarnMsg, Bag ErrMsg),
rn_occs :: SSTRef s ([Occurrence],[Occurrence]), -- Occurrences: compulsory and optional resp
- rn_mod :: Module
+ rn_hi_map :: ModuleHiMap, -- for .hi files
+ rn_hiboot_map :: ModuleHiMap, -- for .hi-boot files
+ rn_mod :: Module
}
type Occurrence = (Name, SrcLoc) -- The srcloc is the occurrence site
-- For getting global names
data GDown = GDown {
- rn_hi_map :: ModuleHiMap, -- for .hi files
- rn_hiboot_map :: ModuleHiMap, -- for .hi-boot files
rn_ifaces :: SSTRWRef Ifaces
}
type SearchPath = [(String,String)] -- List of (directory,suffix) pairs to search
-- for interface files.
-type ModuleHiMap = FiniteMap String String
+type ModuleHiMap = FiniteMap String (String, Bool)
-- mapping from module name to the file path of its corresponding
-- interface file.
\end{code}
data ParsedIface
= ParsedIface
- Module -- Module name
Version -- Module version number
[ImportVersion OccName] -- Usages
[ExportItem] -- Exports
ExportEnv, -- What this module exports
[Module]) -- Instance modules
+
+-- needed by Main to fish out the fixities assoc list.
+getIfaceFixities :: InterfaceDetails -> Fixities
+getIfaceFixities (_, ExportEnv _ fs, _) = fs
+
+
type RdrNamePragma = () -- Fudge for now
-------------------
let
rn_down = RnDown { rn_loc = loc, rn_omit = \n -> False, rn_ns = names_var,
rn_errs = errs_var, rn_occs = occs_var,
+ rn_hi_map = himap, rn_hiboot_map = hibmap,
rn_mod = mod }
- g_down = GDown { rn_hi_map = himap, rn_hiboot_map = hibmap, rn_ifaces = iface_var }
+ g_down = GDown {rn_ifaces = iface_var }
-- do the business
res <- sstToIO (do_rn rn_down g_down)
-- to do as much as possible explicitly.
\end{code}
+We (allege) that it is quicker to build up a mapping from module names
+to the paths to their corresponding interface files once, than to search
+along the import part every time we slurp in a new module (which we
+do quite a lot of.)
+
\begin{code}
mkModuleHiMaps :: SearchPath -> IO (ModuleHiMap, ModuleHiMap)
mkModuleHiMaps dirs = foldM (getAllFilesMatching dirs) (env,env) dirs
where
env = emptyFM
+{- a pseudo file which signals that the interface files
+ contained in a particular directory have got their
+ corresponding object codes stashed away in a DLL
+
+ This stuff is only needed to deal with Win32 DLLs,
+ and conceivably we conditionally compile in support
+ for handling it. (ToDo?)
+-}
+dir_contain_dll_his = "dLL_ifs.hi"
+
getAllFilesMatching :: SearchPath
-> (ModuleHiMap, ModuleHiMap)
-> (FilePath, String)
-> IO (ModuleHiMap, ModuleHiMap)
getAllFilesMatching dirs hims (dir_path, suffix) = ( do
-- fpaths entries do not have dir_path prepended
- fpaths <- getDirectoryContents dir_path
- return (foldl addModules hims fpaths)
+ fpaths <- getDirectoryContents dir_path
+ is_dyns <- catch
+ (if dir_path == "." || opt_Static then
+ return False
+ else
+ doesFileExist (dir_path ++ '/': dir_contain_dll_his))
+ (\ _ {-don't care-} -> return False)
+ return (foldl (addModules is_dyns) hims fpaths)
) -- soft failure
`catch`
(\ err -> do
- hPutStrLn stderr
+ hPutStrLn stderr
("Import path element `" ++ dir_path ++
if (isDoesNotExistError err) then
"' does not exist, ignoring."
reverse (show interfaceFileFormatVersion) ++ '-':hi_boot_xiffus
hi_boot_xiffus = "toob-ih." -- .hi-boot reversed.
- addModules his@(hi_env, hib_env) nm = fromMaybe his $
- FMAP (\ (mod_nm,v) -> (addToFM_C addNewOne hi_env mod_nm v, hib_env))
+ addModules is_dll his@(hi_env, hib_env) nm = fromMaybe his $
+ FMAP (\ (mod_nm,v) -> (addToFM_C addNewOne hi_env mod_nm (v, is_dll), hib_env))
(go xiffus rev_nm) `seqMaybe`
- FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C overrideNew hib_env mod_nm v))
+ FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C overrideNew hib_env mod_nm (v,is_dll)))
(go hi_boot_version_xiffus rev_nm) `seqMaybe`
- FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C addNewOne hib_env mod_nm v))
+ FMAP (\ (mod_nm,v) -> (hi_env, addToFM_C addNewOne hib_env mod_nm (v,is_dll)))
(go hi_boot_xiffus rev_nm)
where
rev_nm = reverse nm
conflict old_path new_path
| old_path /= new_path =
- pprTrace "Warning: " (text "Identically named interface files present on import path, " $$
+ pprTrace "Warning: " (text "Identically named interface files present on the import path, " $$
text (show old_path) <+> text "shadows" $$
text (show new_path) $$
text "on the import path: " <+>
setIfacesRn ifaces rn_down (GDown {rn_ifaces = iface_var})
= writeMutVarSST iface_var ifaces
-getModuleHiMap :: Bool -> RnMG ModuleHiMap
-getModuleHiMap want_hi_boot rn_down (GDown {rn_hi_map = himap, rn_hiboot_map = hibmap})
+getModuleHiMap :: Bool -> RnM s d ModuleHiMap
+getModuleHiMap want_hi_boot (RnDown {rn_hi_map = himap, rn_hiboot_map = hibmap}) _
| want_hi_boot = returnSST hibmap
| otherwise = returnSST himap
+\end{code}
+
+The interface file format is capable of distinguishing
+between normal imports/exports of names from other modules
+and 'hi-boot' mentions of names, with the flavour in the
+being encoded inside a @Module@.
+
+@setModuleFlavourRn@ fixes up @Module@ values containing
+normal flavours, checking to see whether
+
+\begin{code}
+setModuleFlavourRn :: Module -> RnM s d Module
+setModuleFlavourRn mod
+ | bootFlavour hif = returnRn mod
+ | otherwise =
+ getModuleHiMap (bootFlavour hif) `thenRn` \ himap ->
+ let mod_pstr = moduleString mod in
+ case (lookupFM himap mod_pstr) of
+ Nothing -> returnRn mod
+ Just (_,is_in_a_dll) ->
+ returnRn (setModuleFlavour (mkDynFlavour is_in_a_dll hif) mod)
+ where
+ hif = moduleIfaceFlavour mod
\end{code}
import UniqFM ( lookupUFM )
import Bag ( bagToList )
import Maybes ( maybeToBool )
+import Module ( pprModule )
import NameSet
import Name
import RdrName ( RdrName, rdrNameOcc, mkRdrQual, mkRdrUnqual )
importsFromImportDecl (ImportDecl imp_mod qual_only as_mod import_spec iloc)
= pushSrcLocRn iloc $
- getInterfaceExports imp_mod `thenRn` \ avails ->
+ getInterfaceExports imp_mod `thenRn` \ (imp_mod, avails) ->
if null avails then
-- If there's an error in getInterfaceExports, (e.g. interface
projects / ghc-hetmet.git / commitdiff