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
import CabalApi (dependPackages)
import CabalApi (cabalBuildInfo, cabalDependPackages)
import Control.Applicative
import Control.Exception
import Control.Monad
import CoreMonad
import Data.List
import Data.Maybe
import Distribution.PackageDescription
import Distribution.PackageDescription.Parse (readPackageDescription)
import Distribution.Verbosity (silent)
import Distribution.PackageDescription (BuildInfo(..), usedExtensions)
import ErrMsg
import GHC
import GHCApi
@ -34,7 +31,7 @@ initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal
return (fileName,logReader)
withCabal = do
(owdir,cdir,cfile) <- liftIO getDirs
binfo@BuildInfo{..} <- liftIO $ parseCabalFile cfile
binfo@BuildInfo{..} <- liftIO $ cabalBuildInfo cfile
let exts = map (addX . Gap.extensionToString) $ usedExtensions binfo
lang = maybe "-XHaskell98" (addX . show) defaultLanguage
libs = map ("-l" ++) extraLibs
@ -43,26 +40,13 @@ initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal
idirs = case hsSourceDirs of
[] -> [cdir,owdir]
dirs -> map (cdir </>) dirs ++ [owdir]
depPkgs <- liftIO $ dependPackages cfile
depPkgs <- liftIO $ cabalDependPackages cfile
logReader <- initSession opt gopts idirs (Just depPkgs) logging
return (fileName,logReader)
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
getDirs :: IO (FilePath,FilePath,FilePath)
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 Distribution.Verbosity (silent)
@ -8,11 +13,28 @@ import Distribution.Package (Dependency(Dependency), PackageName(PackageName))
import Distribution.PackageDescription
(GenericPackageDescription,
condLibrary, condExecutables, condTestSuites, condBenchmarks,
CondTree, condTreeConstraints)
BuildInfo, usedExtensions, libBuildInfo, buildInfo,
CondTree, condTreeConstraints, condTreeData)
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 = readPackageDescription silent
@ -31,8 +53,8 @@ allDependsOfDescription pd =
getDependencyPackageName :: Dependency -> String
getDependencyPackageName (Dependency (PackageName n) _) = n
dependPackages :: FilePath -> IO [String]
dependPackages =
cabalDependPackages :: FilePath -> IO [String]
cabalDependPackages =
fmap (toList . fromList
. map getDependencyPackageName
. allDependsOfDescription)