module Language.Haskell.Packages ( getPkgInfos ) where
import Prelude hiding (Maybe)
import qualified System.Info
import Control.Applicative
import Data.List
import Data.Maybe
import Control.Monad
import Distribution.InstalledPackageInfo
import Distribution.Text
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
type InstalledPackageInfoString = InstalledPackageInfo_ String
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 = TOOL_VERSION_ghc
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 }
where convert = mapMaybe simpleParse
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