Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
tree: c3f566b327
Fetching contributors…

Cannot retrieve contributors at this time

208 lines (181 sloc) 7.361 kB
{-# LANGUAGE CPP, ScopedTypeVariables #-}
-- |
-- Module : Scion.Packages
-- Author : Thiago Arrais
-- Copyright : (c) Thiago Arrais 2009
-- License : BSD-style
-- Url : http://stackoverflow.com/questions/1522104/how-to-programmatically-retrieve-ghc-package-information
--
-- Maintainer : nominolo@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- Cabal-related functionality.
module Scion.Packages ( getPkgInfos ) where
import Prelude hiding (Maybe)
import qualified Config
import qualified System.Info
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
#if __GLASGOW_HASKELL__ < 702
catchIOError :: IO a -> (IOError -> IO a) -> IO a
catchIOError = catch
#else
import System.IO.Error (catchIOError)
#endif
-- this was borrowed from the ghc-pkg source:
type InstalledPackageInfoString = InstalledPackageInfo_ String
-- | Types of cabal package databases
data CabalPkgDBType =
PkgDirectory FilePath
| PkgFile FilePath
type InstalledPackagesList = [(FilePath, [InstalledPackageInfo])]
-- | Fetch the installed package info from the global and user package.conf
-- databases, mimicking the functionality of ghc-pkg.
getPkgInfos :: IO InstalledPackagesList
getPkgInfos =
let
-- | Test for package database's presence in a given directory
-- NB: The directory is returned for later scanning by listConf,
-- which parses the actual package database file(s).
lookForPackageDBIn :: FilePath -> IO (Maybe InstalledPackagesList)
lookForPackageDBIn dir =
let
path_dir = dir </> "package.conf.d"
path_file = dir </> "package.conf"
in do
exists_dir <- doesDirectoryExist path_dir
if exists_dir
then do
pkgs <- readContents (PkgDirectory path_dir)
return $ Just pkgs
else do
exists_file <- doesFileExist path_file
if exists_file
then do
pkgs <- readContents (PkgFile path_file)
return $ Just pkgs
else return Nothing
currentArch :: String
currentArch = System.Info.arch
currentOS :: String
currentOS = System.Info.os
ghcVersion :: String
ghcVersion = Config.cProjectVersion
in do
-- Get the global package configuration database:
global_conf <- do
r <- lookForPackageDBIn getLibDir
case r of
Nothing -> ioError $ userError ("Can't find package database in " ++ getLibDir)
Just pkgs -> return $ pkgs
-- Get the user package configuration database
e_appdir <- Exc.try $ getAppUserDataDirectory "ghc"
user_conf <- do
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
-- Process GHC_PACKAGE_PATH, if present:
e_pkg_path <- Exc.try $ getEnv "GHC_PACKAGE_PATH"
env_stack <- do
case e_pkg_path of
Left (_::Exc.IOException) -> return []
Right path -> do
pkgs <- mapM readContents [(PkgDirectory pkg) | pkg <- splitSearchPath path]
return $ concat pkgs
-- Send back the combined installed packages list:
return (env_stack ++ user_conf ++ global_conf)
-- | Read the contents of the given directory, searching for ".conf" files, and parse the
-- package contents. Returns a singleton list (directory, [installed packages])
readContents :: CabalPkgDBType -- ^ The package database
-> IO [(FilePath, [InstalledPackageInfo])] -- ^ Installed packages
readContents pkgdb =
let
-- | List package configuration files that might live in the given directory
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, isSuffixOf ".conf" file]
else return []
-- | Read a file, ensuring that UTF8 coding is used for GCH >= 6.12
readUTF8File :: FilePath -> IO String
readUTF8File file = do
h <- openFile file ReadMode
#if __GLASGOW_HASKELL__ >= 612
-- fix the encoding to UTF-8
hSetEncoding h utf8
catchIOError (hGetContents h) (\_ -> do
-- logInfo $ ioeGetErrorString err
hClose h
h' <- openFile file ReadMode
hSetEncoding h' localeEncoding
hGetContents h'
)
#else
hGetContents h
#endif
-- | This function was lifted directly from ghc-pkg. Its sole purpose is
-- parsing an input package description string and producing an
-- InstalledPackageInfo structure.
convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
convertPackageInfoIn
(pkgconf@(InstalledPackageInfo { exposedModules = e,
hiddenModules = h })) =
pkgconf{ exposedModules = map convert e,
hiddenModules = map convert h }
where convert = fromJust . simpleParse
-- | Utility function that just flips the arguments to Control.Exception.catch
catchError :: IO a -> (String -> IO a) -> IO a
catchError io handler = io `Exception.catch` handler'
where handler' (Exception.ErrorCall err) = handler err
-- | Slightly different approach in Cabal 1.8 series, with the package.conf.d
-- directories, where individual package configuration files are association
-- pairs.
pkgInfoReader :: FilePath
-> IO [InstalledPackageInfo]
pkgInfoReader f =
catchIOError (
do
pkgStr <- readUTF8File f
let pkgInfo = parseInstalledPackageInfo pkgStr
case pkgInfo of
ParseOk _ info -> return [info]
ParseFailed _ -> do
-- logInfo (show err)
return [emptyInstalledPackageInfo]
) (\_->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 $ read pkgStr
pkgInfoList <-
Exception.evaluate pkgs
`catchError`
(\e-> ioError $ userError $ "parsing " ++ dbFile ++ ": " ++ (show e))
return [(takeDirectory dbFile, pkgInfoList)]
-- GHC.Path sets libdir for us...
getLibDir :: String
getLibDir = libdir
Jump to Line
Something went wrong with that request. Please try again.