fix-topdir-and-windll-loading

This commit is contained in:
vivian.mcphail 2005-05-07 03:58:08 +00:00
parent 2de3b1180b
commit ab72dff6c4
2 changed files with 30 additions and 12 deletions

View File

@ -284,22 +284,23 @@ readPackageConf f = do
-- We return all the package paths that possibly exist, and the leave it
-- up to loadObject not to load the same ones twice...
--
lookupPkg :: PackageName -> IO [FilePath]
lookupPkg :: PackageName -> IO ([FilePath],[FilePath])
lookupPkg p = do
t <- lookupPkg' p
case t of ([],f) -> return f
(ps,f) -> do gss <- mapM lookupPkg ps
return $ nub $ (concat gss) ++ f
case t of ([],(f,g)) -> return (f,g)
(ps,(f,g)) -> do gss <- mapM lookupPkg ps
let (f',g') = unzip gss
return $ (nub $ (concat f') ++ f,nub $ (concat g') ++ g)
--
-- return any stuff to load for this package, plus the list of packages
-- this package depends on. which includes stuff we have to then load
-- too.
--
lookupPkg' :: PackageName -> IO ([PackageName],[FilePath])
lookupPkg' :: PackageName -> IO ([PackageName],([FilePath],[FilePath]))
lookupPkg' p = withPkgEnvs env $ \fms -> go fms p
where
go [] _ = return ([],[])
go [] _ = return ([],([],[]))
go (fm:fms) q = case lookupFM fm q of
Nothing -> go fms q -- look in other pkgs
@ -313,7 +314,17 @@ lookupPkg' p = withPkgEnvs env $ \fms -> go fms p
-- don't care if there are 'Nothings', that usually
-- means that they refer to system libraries. Can't do
-- anything about that.
return (deppkgs, filterJust libs )
return (deppkgs, (filterJust libs,filterJust libs') )
-- replace $topdir
fix_topdir [] = []
fix_topdir (x:xs) = replace_topdir x : fix_topdir xs
replace_topdir [] = []
replace_topdir ('$':xs)
| take 6 xs == "topdir" = ghcLibraryPath ++ (drop 6 xs)
| otherwise = '$' : replace_topdir xs
replace_topdir (x:xs) = x : replace_topdir xs
-- a list elimination form for the Maybe type
filterJust :: [Maybe a] -> [a]
@ -334,6 +345,13 @@ lookupPkg' p = withPkgEnvs env $ \fms -> go fms p
if b then return $ Just l -- found it!
else findHSlib dirs lib
findDLL :: FilePath -> String -> IO (Maybe FilePath)
findDLL dir lib = do
let l = dir ++ "/" ++ lib ++ ".dll"
b <- doesFileExist l
if b then return $ Just l
else return $ Nothing
------------------------------------------------------------------------
-- do we have a Module name for this merge?
--

View File

@ -453,7 +453,7 @@ loadRawObject obj = loadObject obj (Object k)
-- | Resolve (link) the modules loaded by the 'loadObject' function.
--
resolveObjs :: IO ()
resolveObjs = do
resolveObjs = do
r <- c_resolveObjs
when (not r) $
panic $ "resolveObjs failed with <<" ++ show r ++ ">>"
@ -480,7 +480,7 @@ loadShared str = do
if maybe_errmsg == nullPtr
then return (Module str (mkModid str) Shared emptyIface (Package (mkModid str)))
else do e <- peekCString maybe_errmsg
panic $ "loadShared: couldn't load `"++str++"\' because "++e
panic $ "loadShared: couldn't load `"++str'++"\' because "++e
--
-- Load a -package that we might need, implicitly loading the cbits too
@ -498,7 +498,7 @@ loadPackage p = do
#endif
libs <- lookupPkg p
mapM_ (\l -> loadObject l (Package (mkModid l))) libs
mapM_ loadShared dlls
--
-- Unload a -package, that has already been loaded. Unload the cbits
-- too. The argument is the name of the package.
@ -513,7 +513,7 @@ loadPackage p = do
unloadPackage :: String -> IO ()
unloadPackage pkg = do
let pkg' = takeWhile (/= '-') pkg -- in case of *-0.1
libs <- liftM (filter (isSublistOf pkg')) (lookupPkg pkg)
libs <- liftM (\(a,_) -> (filter (isSublistOf pkg') ) a) (lookupPkg pkg)
flip mapM_ libs $ \p -> withCString p $ \c_p -> do
r <- c_unloadObj c_p
when (not r) (panic "unloadObj: failed")
@ -568,7 +568,7 @@ loadDepends obj incpaths = do
else do hiface <- readIface hifile
let ds = mi_deps hiface
-- remove ones that we've already loaded
ds' <- filterM loaded (dep_mods ds)