module Language.Haskell.Packages ( getPkgInfos ) where
import Prelude hiding (Maybe)
import qualified System.Info
import qualified Config
import Data.List
import Data.Maybe
import Control.Monad
import Distribution.InstalledPackageInfo
#if MIN_VERSION_Cabal(1,22,0)
import Distribution.ModuleName
#else
import Control.Applicative
import Distribution.Text
#endif
import System.Directory
import System.Environment (getEnv)
import System.FilePath
import System.IO
import qualified Control.Exception as Exc
import GHC.Paths
import qualified Control.Exception as Exception
#if MIN_VERSION_Cabal(1,22,0)
type InstalledPackageInfoString = InstalledPackageInfo_ ModuleName
#else
type InstalledPackageInfoString = InstalledPackageInfo_ String
#endif
data CabalPkgDBType =
PkgDirectory FilePath
| PkgFile FilePath
type InstalledPackagesList = [(FilePath, [InstalledPackageInfo])]
getPkgInfos :: Maybe FilePath
-> IO InstalledPackagesList
getPkgInfos msandbox=
let
lookForPackageDBIn :: FilePath -> IO (Maybe InstalledPackagesList)
lookForPackageDBIn dir =
let
path_dir = dir </> "package.conf.d"
path_file = dir </> "package.conf"
path_sd_dir= dir </> ("packages-" ++ ghcVersion ++ ".conf")
path_ghc_dir= dir </> currentArch ++ '-' : currentOS ++ "-ghc-" ++ ghcVersion ++ "-packages.conf.d"
in join . listToMaybe . filter isJust <$>
mapM readIfExists [PkgDirectory path_dir,PkgFile path_file,PkgDirectory path_sd_dir,PkgDirectory path_ghc_dir]
currentArch :: String
currentArch = System.Info.arch
currentOS :: String
currentOS = System.Info.os
ghcVersion :: String
ghcVersion = Config.cProjectVersion
in do
global_conf <- do
r <- lookForPackageDBIn getLibDir
case r of
Nothing -> ioError $ userError ("Can't find package database in " ++ getLibDir)
Just pkgs -> return pkgs
user_conf <- case msandbox of
Nothing -> do
e_appdir <- Exc.try $ getAppUserDataDirectory "ghc"
case e_appdir of
Left (_::Exc.IOException) -> return []
Right appdir -> do
let subdir
= currentArch ++ '-' : currentOS ++ '-' : ghcVersion
dir = appdir </> subdir
r <- lookForPackageDBIn dir
case r of
Nothing -> return []
Just pkgs -> return pkgs
Just sd->do
r <- lookForPackageDBIn sd
case r of
Nothing -> return []
Just pkgs -> return pkgs
e_pkg_path <- Exc.try (getEnv "GHC_PACKAGE_PATH")
env_stack <- case e_pkg_path of
Left (_::Exc.IOException) -> return []
Right path -> do
pkgs <- mapM readContents [PkgDirectory pkg | pkg <- splitSearchPath path]
return $ concat pkgs
return (env_stack ++ user_conf ++ global_conf)
readIfExists :: CabalPkgDBType -> IO (Maybe InstalledPackagesList)
readIfExists p@(PkgDirectory path_dir) = do
exists_dir <- doesDirectoryExist path_dir
if exists_dir
then Just <$> readContents p
else return Nothing
readIfExists p@(PkgFile path_dir) = do
exists_dir <- doesFileExist path_dir
if exists_dir
then Just <$> readContents p
else return Nothing
readContents :: CabalPkgDBType
-> IO InstalledPackagesList
readContents pkgdb =
let
listConf :: FilePath -> IO [FilePath]
listConf dbdir = do
conf_dir_exists <- doesDirectoryExist dbdir
if conf_dir_exists
then do
files <- getDirectoryContents dbdir
return [ dbdir </> file | file <- files, ".conf" `isSuffixOf` file]
else return []
readUTF8File :: FilePath -> IO String
readUTF8File file = do
h <- openFile file ReadMode
#if __GLASGOW_HASKELL__ >= 612
hSetEncoding h utf8
Exc.catch (hGetContents h) (\(err :: Exc.IOException)->do
print err
hClose h
h' <- openFile file ReadMode
hSetEncoding h' localeEncoding
hGetContents h'
)
#else
hGetContents h
#endif
convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
convertPackageInfoIn
(pkgconf@(InstalledPackageInfo { exposedModules = e,
hiddenModules = h })) =
pkgconf{ exposedModules = convert e,
hiddenModules = convert h }
#if MIN_VERSION_Cabal(1,22,0)
where convert = map id
#else
where convert = mapMaybe simpleParse
#endif
catchError :: IO a -> (String -> IO a) -> IO a
catchError io handler = io `Exception.catch` handler'
where handler' (Exception.ErrorCall err) = handler err
pkgInfoReader :: FilePath
-> IO [InstalledPackageInfo]
pkgInfoReader f =
Exc.catch (
do
pkgStr <- readUTF8File f
let pkgInfo = parseInstalledPackageInfo pkgStr
case pkgInfo of
ParseOk _ info -> return [info]
ParseFailed err -> do
print err
return [emptyInstalledPackageInfo]
) (\(_::Exc.IOException)->return [emptyInstalledPackageInfo])
in case pkgdb of
(PkgDirectory pkgdbDir) -> do
confs <- listConf pkgdbDir
pkgInfoList <- mapM pkgInfoReader confs
return [(pkgdbDir, join pkgInfoList)]
(PkgFile dbFile) -> do
pkgStr <- readUTF8File dbFile
let pkgs = map convertPackageInfoIn $ readObj "InstalledPackageInfo" pkgStr
pkgInfoList <-
Exception.evaluate pkgs
`catchError`
(\e-> ioError $ userError $ "parsing " ++ dbFile ++ ": " ++ show e)
return [(takeDirectory dbFile, pkgInfoList)]
getLibDir :: String
getLibDir = libdir
readObj :: Read a=> String -> String -> a
readObj msg s=let parses=reads s
in if null parses
then error (msg ++ ": " ++ s ++ ".")
else fst $ head parses