fix-topdir-and-windll-loading
This commit is contained in:
parent
2de3b1180b
commit
ab72dff6c4
@ -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?
|
||||||
--
|
--
|
||||||
|
@ -453,7 +453,7 @@ loadRawObject obj = loadObject obj (Object k)
|
|||||||
-- | Resolve (link) the modules loaded by the 'loadObject' function.
|
-- | Resolve (link) the modules loaded by the 'loadObject' function.
|
||||||
--
|
--
|
||||||
resolveObjs :: IO ()
|
resolveObjs :: IO ()
|
||||||
resolveObjs = do
|
resolveObjs = do
|
||||||
r <- c_resolveObjs
|
r <- c_resolveObjs
|
||||||
when (not r) $
|
when (not r) $
|
||||||
panic $ "resolveObjs failed with <<" ++ show r ++ ">>"
|
panic $ "resolveObjs failed with <<" ++ show r ++ ">>"
|
||||||
@ -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")
|
||||||
@ -568,7 +568,7 @@ loadDepends obj incpaths = do
|
|||||||
|
|
||||||
else do hiface <- readIface hifile
|
else do hiface <- readIface hifile
|
||||||
let ds = mi_deps hiface
|
let ds = mi_deps hiface
|
||||||
|
|
||||||
-- remove ones that we've already loaded
|
-- remove ones that we've already loaded
|
||||||
ds' <- filterM loaded (dep_mods ds)
|
ds' <- filterM loaded (dep_mods ds)
|
||||||
|
|
||||||
|
Loading…
x
Reference in New Issue
Block a user