Move an interface function with Cabal package into CabalApi module.

This commit is contained in:
Kei Hibino 2012-10-24 10:06:24 +09:00
parent ff9fa49141
commit c74b58a47f
2 changed files with 31 additions and 25 deletions

View File

@ -2,16 +2,13 @@
module Cabal (initializeGHC) where module Cabal (initializeGHC) where
import CabalApi (dependPackages) import CabalApi (cabalBuildInfo, cabalDependPackages)
import Control.Applicative import Control.Applicative
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import CoreMonad import CoreMonad
import Data.List import Data.List
import Data.Maybe import Distribution.PackageDescription (BuildInfo(..), usedExtensions)
import Distribution.PackageDescription
import Distribution.PackageDescription.Parse (readPackageDescription)
import Distribution.Verbosity (silent)
import ErrMsg import ErrMsg
import GHC import GHC
import GHCApi import GHCApi
@ -34,7 +31,7 @@ initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal
return (fileName,logReader) return (fileName,logReader)
withCabal = do withCabal = do
(owdir,cdir,cfile) <- liftIO getDirs (owdir,cdir,cfile) <- liftIO getDirs
binfo@BuildInfo{..} <- liftIO $ parseCabalFile cfile binfo@BuildInfo{..} <- liftIO $ cabalBuildInfo cfile
let exts = map (addX . Gap.extensionToString) $ usedExtensions binfo let exts = map (addX . Gap.extensionToString) $ usedExtensions binfo
lang = maybe "-XHaskell98" (addX . show) defaultLanguage lang = maybe "-XHaskell98" (addX . show) defaultLanguage
libs = map ("-l" ++) extraLibs libs = map ("-l" ++) extraLibs
@ -43,26 +40,13 @@ initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal
idirs = case hsSourceDirs of idirs = case hsSourceDirs of
[] -> [cdir,owdir] [] -> [cdir,owdir]
dirs -> map (cdir </>) dirs ++ [owdir] dirs -> map (cdir </>) dirs ++ [owdir]
depPkgs <- liftIO $ dependPackages cfile depPkgs <- liftIO $ cabalDependPackages cfile
logReader <- initSession opt gopts idirs (Just depPkgs) logging logReader <- initSession opt gopts idirs (Just depPkgs) logging
return (fileName,logReader) return (fileName,logReader)
addX = ("-X" ++) addX = ("-X" ++)
---------------------------------------------------------------- ----------------------------------------------------------------
-- Causes error, catched in the upper function.
parseCabalFile :: FilePath -> IO BuildInfo
parseCabalFile file = do
cabal <- readPackageDescription silent file
return . fromJust $ fromLibrary cabal <|> fromExecutable cabal
where
fromLibrary c = libBuildInfo . condTreeData <$> condLibrary c
fromExecutable c = buildInfo . condTreeData . snd <$> toMaybe (condExecutables c)
toMaybe [] = Nothing
toMaybe (x:_) = Just x
----------------------------------------------------------------
-- CurrentWorkingDir, CabalDir, CabalFile -- CurrentWorkingDir, CabalDir, CabalFile
getDirs :: IO (FilePath,FilePath,FilePath) getDirs :: IO (FilePath,FilePath,FilePath)
getDirs = do getDirs = do

View File

@ -1,6 +1,11 @@
module CabalApi (dependPackages) where module CabalApi (
cabalBuildInfo,
cabalDependPackages
) where
import Data.Maybe (maybeToList) import Control.Applicative
import Data.Maybe (fromJust, maybeToList)
import Data.Set (fromList, toList) import Data.Set (fromList, toList)
import Distribution.Verbosity (silent) import Distribution.Verbosity (silent)
@ -8,11 +13,28 @@ import Distribution.Package (Dependency(Dependency), PackageName(PackageName))
import Distribution.PackageDescription import Distribution.PackageDescription
(GenericPackageDescription, (GenericPackageDescription,
condLibrary, condExecutables, condTestSuites, condBenchmarks, condLibrary, condExecutables, condTestSuites, condBenchmarks,
CondTree, condTreeConstraints) BuildInfo, usedExtensions, libBuildInfo, buildInfo,
CondTree, condTreeConstraints, condTreeData)
import Distribution.PackageDescription.Parse (readPackageDescription) import Distribution.PackageDescription.Parse (readPackageDescription)
-- import Distribution.PackageDescription
-- (BuildInfo(..))
-- import Distribution.PackageDescription.Parse (readPackageDescription)
-- import Distribution.Verbosity (silent)
---------------------------------------------------------------- ----------------------------------------------------------------
-- Causes error, catched in the upper function.
cabalBuildInfo :: FilePath -> IO BuildInfo
cabalBuildInfo file = do
cabal <- readPackageDescription silent file
return . fromJust $ fromLibrary cabal <|> fromExecutable cabal
where
fromLibrary c = libBuildInfo . condTreeData <$> condLibrary c
fromExecutable c = buildInfo . condTreeData . snd <$> toMaybe (condExecutables c)
toMaybe [] = Nothing
toMaybe (x:_) = Just x
parseGenericDescription :: FilePath -> IO GenericPackageDescription parseGenericDescription :: FilePath -> IO GenericPackageDescription
parseGenericDescription = readPackageDescription silent parseGenericDescription = readPackageDescription silent
@ -31,8 +53,8 @@ allDependsOfDescription pd =
getDependencyPackageName :: Dependency -> String getDependencyPackageName :: Dependency -> String
getDependencyPackageName (Dependency (PackageName n) _) = n getDependencyPackageName (Dependency (PackageName n) _) = n
dependPackages :: FilePath -> IO [String] cabalDependPackages :: FilePath -> IO [String]
dependPackages = cabalDependPackages =
fmap (toList . fromList fmap (toList . fromList
. map getDependencyPackageName . map getDependencyPackageName
. allDependsOfDescription) . allDependsOfDescription)