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 -- We return all the package paths that possibly exist, and the leave it
-- up to loadObject not to load the same ones twice... -- up to loadObject not to load the same ones twice...
-- --
lookupPkg :: PackageName -> IO [FilePath] lookupPkg :: PackageName -> IO ([FilePath],[FilePath])
lookupPkg p = do lookupPkg p = do
t <- lookupPkg' p t <- lookupPkg' p
case t of ([],f) -> return f case t of ([],(f,g)) -> return (f,g)
(ps,f) -> do gss <- mapM lookupPkg ps (ps,(f,g)) -> do gss <- mapM lookupPkg ps
return $ nub $ (concat gss) ++ f 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 -- 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 -- this package depends on. which includes stuff we have to then load
-- too. -- too.
-- --
lookupPkg' :: PackageName -> IO ([PackageName],[FilePath]) lookupPkg' :: PackageName -> IO ([PackageName],([FilePath],[FilePath]))
lookupPkg' p = withPkgEnvs env $ \fms -> go fms p lookupPkg' p = withPkgEnvs env $ \fms -> go fms p
where where
go [] _ = return ([],[]) go [] _ = return ([],([],[]))
go (fm:fms) q = case lookupFM fm q of go (fm:fms) q = case lookupFM fm q of
Nothing -> go fms q -- look in other pkgs 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 -- don't care if there are 'Nothings', that usually
-- means that they refer to system libraries. Can't do -- means that they refer to system libraries. Can't do
-- anything about that. -- 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 -- a list elimination form for the Maybe type
filterJust :: [Maybe a] -> [a] filterJust :: [Maybe a] -> [a]
@ -334,6 +345,13 @@ lookupPkg' p = withPkgEnvs env $ \fms -> go fms p
if b then return $ Just l -- found it! if b then return $ Just l -- found it!
else findHSlib dirs lib 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? -- do we have a Module name for this merge?
-- --

View File

@ -480,7 +480,7 @@ loadShared str = do
if maybe_errmsg == nullPtr if maybe_errmsg == nullPtr
then return (Module str (mkModid str) Shared emptyIface (Package (mkModid str))) then return (Module str (mkModid str) Shared emptyIface (Package (mkModid str)))
else do e <- peekCString maybe_errmsg 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 -- Load a -package that we might need, implicitly loading the cbits too
@ -498,7 +498,7 @@ loadPackage p = do
#endif #endif
libs <- lookupPkg p libs <- lookupPkg p
mapM_ (\l -> loadObject l (Package (mkModid l))) libs mapM_ (\l -> loadObject l (Package (mkModid l))) libs
mapM_ loadShared dlls
-- --
-- Unload a -package, that has already been loaded. Unload the cbits -- Unload a -package, that has already been loaded. Unload the cbits
-- too. The argument is the name of the package. -- too. The argument is the name of the package.
@ -513,7 +513,7 @@ loadPackage p = do
unloadPackage :: String -> IO () unloadPackage :: String -> IO ()
unloadPackage pkg = do unloadPackage pkg = do
let pkg' = takeWhile (/= '-') pkg -- in case of *-0.1 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 flip mapM_ libs $ \p -> withCString p $ \c_p -> do
r <- c_unloadObj c_p r <- c_unloadObj c_p
when (not r) (panic "unloadObj: failed") when (not r) (panic "unloadObj: failed")