added support for --user package discovery

This patch allows run plugins, containig
import of --user installed packages. Useful
for lambdabot installation in $HOME.

package.conf are found by parsing `ghc-pkg list`
This commit is contained in:
Sergei Trofimovich 2008-08-20 12:55:16 +00:00
parent 3e128d4b58
commit d548687001

View File

@ -61,13 +61,14 @@ import System.Plugins.Consts ( ghcLibraryPath, sysPkgConf, sysPkgSuffi
import Data.IORef ( writeIORef, readIORef, newIORef, IORef() ) import Data.IORef ( writeIORef, readIORef, newIORef, IORef() )
import Data.Maybe ( isJust, isNothing, fromMaybe ) import Data.Maybe ( isJust, isNothing, fromMaybe )
import Data.List ( isPrefixOf, nub ) import Data.List ( isPrefixOf, isInfixOf, nub )
import System.IO.Unsafe ( unsafePerformIO ) import System.IO.Unsafe ( unsafePerformIO )
import System.IO ( hGetContents )
import System.Directory ( doesFileExist ) import System.Directory ( doesFileExist )
import System.Process ( waitForProcess, runInteractiveCommand )
#if defined(CYGWIN) || defined(__MINGW32__) #if defined(CYGWIN) || defined(__MINGW32__)
import Prelude hiding ( catch, ioError ) import Prelude hiding ( catch, ioError )
import System.Environment ( getEnv )
import System.IO.Error ( catch, ioError, isDoesNotExistError ) import System.IO.Error ( catch, ioError, isDoesNotExistError )
#endif #endif
@ -297,9 +298,11 @@ union ls ps' =
-- --
grabDefaultPkgConf :: IO PkgEnvs grabDefaultPkgConf :: IO PkgEnvs
grabDefaultPkgConf = do grabDefaultPkgConf = do
pkgs <- readPackageConf $ ghcLibraryPath </> sysPkgConf pkg_confs <- get_ghc_configs
return $ union [] pkgs packages <- mapM readPackageConf pkg_confs
return $ foldl union [] packages
-- --
-- parse a source file, expanding any $libdir we see. -- parse a source file, expanding any $libdir we see.
@ -514,3 +517,26 @@ addMerge a b z = modifyMerged env $ \fm -> return $ addToFM fm (a,b) z
(</>) :: FilePath -> FilePath -> FilePath (</>) :: FilePath -> FilePath -> FilePath
[] </> b = b [] </> b = b
a </> b = a ++ "/" ++ b a </> b = a ++ "/" ++ b
-------------------------------------------------------------------------
--
-- 'run_cmd' executes command and returns it's standard output
-- as 'String'
run_cmd :: String -> IO String
run_cmd cmd = do (_hI, hO, _hE, hProcess) <- runInteractiveCommand cmd
output <- hGetContents hO
_exitCode <- waitForProcess hProcess
return output
--
-- 'get_ghc_configs' returns list of strings of packages.conf files in system
get_ghc_configs :: IO [String]
get_ghc_configs = do ghc_out <- run_cmd "ghc-pkg list"
let configs = map (reverse.strip_trash.reverse) $
filter (isInfixOf sysPkgConf) $ lines ghc_out
return configs
-- | strip ":\r?" from string head
where strip_trash [] = []
strip_trash xs@(x:xs') | x `elem` ":\r" = strip_trash xs'
| otherwise = xs