{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Hhp.CabalApi (
getCompilerOptions
, parseCabalFile
, cabalAllBuildInfo
, cabalDependPackages
, cabalSourceDirs
, cabalAllTargets
) where
import Distribution.Compiler (unknownCompilerInfo, AbiTag(NoAbiTag))
import Distribution.ModuleName (ModuleName,toFilePath)
import Distribution.Package (Dependency(Dependency))
import qualified Distribution.Package as C
import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable)
import qualified Distribution.PackageDescription as P
import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))
import Distribution.Simple.Program (ghcProgram)
import Distribution.Simple.Program.Types (programName, programFindVersion)
import Distribution.System (buildPlatform)
import Distribution.Text (display)
import Distribution.Verbosity (silent)
import Distribution.Version (Version)
import Distribution.PackageDescription.Configuration (finalizePD)
#if MIN_VERSION_Cabal(3,8,0)
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
#else
import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
#endif
import Distribution.Types.ComponentRequestedSpec (defaultComponentRequestedSpec)
import Distribution.Types.Flag (mkFlagAssignment, mkFlagName)
import Distribution.Types.PackageName (unPackageName)
#if MIN_VERSION_Cabal(3,6,0)
import Distribution.Utils.Path (getSymbolicPath, SymbolicPath)
#endif
import GHC.Utils.Monad (liftIO)
import Control.Exception (throwIO)
import Control.Monad (filterM)
import Data.Maybe (maybeToList, mapMaybe, fromMaybe)
import Data.Set (fromList, toList)
import System.Directory (doesFileExist)
import System.Environment (lookupEnv)
import System.FilePath (dropExtension, takeFileName, (</>))
import Hhp.Types
import Hhp.GhcPkg
getCompilerOptions :: [GHCOption]
-> Cradle
-> PackageDescription
-> IO CompilerOptions
getCompilerOptions :: [String] -> Cradle -> PackageDescription -> IO CompilerOptions
getCompilerOptions [String]
ghcopts Cradle
cradle PackageDescription
pkgDesc = do
[String]
gopts <- [String] -> Cradle -> String -> BuildInfo -> IO [String]
getGHCOptions [String]
ghcopts Cradle
cradle String
rdir forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [BuildInfo]
buildInfos
[Package]
dbPkgs <- [GhcPkgDb] -> IO [Package]
ghcPkgListEx (Cradle -> [GhcPkgDb]
cradlePkgDbStack Cradle
cradle)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String] -> [String] -> [Package] -> CompilerOptions
CompilerOptions [String]
gopts [String]
idirs ([Package] -> [Package]
depPkgs [Package]
dbPkgs)
where
wdir :: String
wdir = Cradle -> String
cradleCurrentDir Cradle
cradle
rdir :: String
rdir = Cradle -> String
cradleRootDir Cradle
cradle
cfile :: String
cfile = forall a. a -> Maybe a -> a
fromMaybe String
"error getCompilerOptions" forall a b. (a -> b) -> a -> b
$ Cradle -> Maybe String
cradleCabalFile Cradle
cradle
thisPkg :: String
thisPkg = String -> String
dropExtension forall a b. (a -> b) -> a -> b
$ String -> String
takeFileName String
cfile
buildInfos :: [BuildInfo]
buildInfos = PackageDescription -> [BuildInfo]
cabalAllBuildInfo PackageDescription
pkgDesc
idirs :: [String]
idirs = String -> String -> [String] -> [String]
includeDirectories String
rdir String
wdir forall a b. (a -> b) -> a -> b
$ [BuildInfo] -> [String]
cabalSourceDirs [BuildInfo]
buildInfos
depPkgs :: [Package] -> [Package]
depPkgs [Package]
ps = [Package] -> [String] -> [Package]
attachPackageIds [Package]
ps
forall a b. (a -> b) -> a -> b
$ [String] -> [String] -> [String]
removeThem ([String]
problematicPackages forall a. [a] -> [a] -> [a]
++ [String
thisPkg])
forall a b. (a -> b) -> a -> b
$ [BuildInfo] -> [String]
cabalDependPackages [BuildInfo]
buildInfos
removeThem :: [PackageBaseName] -> [PackageBaseName] -> [PackageBaseName]
removeThem :: [String] -> [String] -> [String]
removeThem [String]
badpkgs = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
badpkgs)
problematicPackages :: [PackageBaseName]
problematicPackages :: [String]
problematicPackages = [
String
"base-compat"
]
attachPackageIds :: [Package] -> [PackageBaseName] -> [Package]
attachPackageIds :: [Package] -> [String] -> [Package]
attachPackageIds [Package]
pkgs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b c. Eq a => a -> [(a, b, c)] -> Maybe (a, b, c)
`lookup3` [Package]
pkgs)
lookup3 :: Eq a => a -> [(a,b,c)] -> Maybe (a,b,c)
lookup3 :: forall a b c. Eq a => a -> [(a, b, c)] -> Maybe (a, b, c)
lookup3 a
_ [] = forall a. Maybe a
Nothing
lookup3 a
k (t :: (a, b, c)
t@(a
a,b
_,c
_):[(a, b, c)]
ls)
| a
k forall a. Eq a => a -> a -> Bool
== a
a = forall a. a -> Maybe a
Just (a, b, c)
t
| Bool
otherwise = forall a b c. Eq a => a -> [(a, b, c)] -> Maybe (a, b, c)
lookup3 a
k [(a, b, c)]
ls
cabalBuildDirs :: [FilePath]
cabalBuildDirs :: [String]
cabalBuildDirs = [String
"dist/build", String
"dist/build/autogen"]
includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath]
includeDirectories :: String -> String -> [String] -> [String]
includeDirectories String
cdir String
wdir [String]
dirs = [String] -> [String]
uniqueAndSort ([String]
extdirs forall a. [a] -> [a] -> [a]
++ [String
cdir,String
wdir])
where
extdirs :: [String]
extdirs = forall a b. (a -> b) -> [a] -> [b]
map String -> String
expand forall a b. (a -> b) -> a -> b
$ [String]
dirs forall a. [a] -> [a] -> [a]
++ [String]
cabalBuildDirs
expand :: String -> String
expand String
"." = String
cdir
expand String
subdir = String
cdir String -> String -> String
</> String
subdir
parseCabalFile :: FilePath -> IO PackageDescription
parseCabalFile :: String -> IO PackageDescription
parseCabalFile String
file = do
CompilerId
cid <- IO CompilerId
getGHCId
let cid' :: CompilerInfo
cid' = CompilerId -> AbiTag -> CompilerInfo
unknownCompilerInfo CompilerId
cid AbiTag
NoAbiTag
GenericPackageDescription
epgd <- Verbosity -> String -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
silent String
file
FlagAssignment
flags <- IO FlagAssignment
getFlags
case CompilerInfo
-> FlagAssignment
-> GenericPackageDescription
-> Either [Dependency] (PackageDescription, FlagAssignment)
toPkgDesc CompilerInfo
cid' FlagAssignment
flags GenericPackageDescription
epgd of
Left [Dependency]
deps -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> IOError
userError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show [Dependency]
deps forall a. [a] -> [a] -> [a]
++ String
" are not installed"
Right (PackageDescription
pd,FlagAssignment
_) -> if PackageDescription -> Bool
nullPkg PackageDescription
pd
then forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> IOError
userError forall a b. (a -> b) -> a -> b
$ String
file forall a. [a] -> [a] -> [a]
++ String
" is broken"
else forall (m :: * -> *) a. Monad m => a -> m a
return PackageDescription
pd
where
envFlags :: IO [(FlagName, Bool)]
envFlags = do
let parseF :: String -> [(FlagName, Bool)]
parseF [] = []
parseF ccs :: String
ccs@(Char
c:String
cs)
| Char
c forall a. Eq a => a -> a -> Bool
== Char
'-' = [(String -> FlagName
mkFlagName String
cs, Bool
False)]
| Bool
otherwise = [(String -> FlagName
mkFlagName String
ccs, Bool
True)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [(FlagName, Bool)]
parseF forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO (Maybe String)
lookupEnv String
"HHP_CABAL_FLAGS"
getFlags :: IO FlagAssignment
getFlags = [(FlagName, Bool)] -> FlagAssignment
mkFlagAssignment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(FlagName, Bool)]
envFlags
nullPkg :: PackageDescription -> Bool
nullPkg PackageDescription
pd = PackageName -> String
unPackageName (PackageIdentifier -> PackageName
C.pkgName (PackageDescription -> PackageIdentifier
P.package PackageDescription
pd)) forall a. Eq a => a -> a -> Bool
== String
""
toPkgDesc :: CompilerInfo
-> FlagAssignment
-> GenericPackageDescription
-> Either [Dependency] (PackageDescription, FlagAssignment)
toPkgDesc CompilerInfo
cid FlagAssignment
flags = FlagAssignment
-> ComponentRequestedSpec
-> (Dependency -> Bool)
-> Platform
-> CompilerInfo
-> [PackageVersionConstraint]
-> GenericPackageDescription
-> Either [Dependency] (PackageDescription, FlagAssignment)
finalizePD FlagAssignment
flags ComponentRequestedSpec
defaultComponentRequestedSpec (forall a b. a -> b -> a
const Bool
True) Platform
buildPlatform CompilerInfo
cid []
getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption]
getGHCOptions :: [String] -> Cradle -> String -> BuildInfo -> IO [String]
getGHCOptions [String]
ghcopts Cradle
cradle String
rdir BuildInfo
binfo = do
[String]
cabalCpp <- String -> IO [String]
cabalCppOptions String
rdir
let cpps :: [String]
cpps = forall a b. (a -> b) -> [a] -> [b]
map (String
"-optP" forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ BuildInfo -> [String]
P.cppOptions BuildInfo
binfo forall a. [a] -> [a] -> [a]
++ [String]
cabalCpp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String]
ghcopts forall a. [a] -> [a] -> [a]
++ [String]
pkgDb forall a. [a] -> [a] -> [a]
++ [String]
exts forall a. [a] -> [a] -> [a]
++ [String
lang] forall a. [a] -> [a] -> [a]
++ [String]
libs forall a. [a] -> [a] -> [a]
++ [String]
libDirs forall a. [a] -> [a] -> [a]
++ [String]
cpps
where
pkgDb :: [String]
pkgDb = [GhcPkgDb] -> [String]
ghcDbStackOpts forall a b. (a -> b) -> a -> b
$ Cradle -> [GhcPkgDb]
cradlePkgDbStack Cradle
cradle
lang :: String
lang = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"-XHaskell98" ((String
"-X" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> String
display) forall a b. (a -> b) -> a -> b
$ BuildInfo -> Maybe Language
P.defaultLanguage BuildInfo
binfo
libDirs :: [String]
libDirs = forall a b. (a -> b) -> [a] -> [b]
map (String
"-L" forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ BuildInfo -> [String]
P.extraLibDirs BuildInfo
binfo
exts :: [String]
exts = forall a b. (a -> b) -> [a] -> [b]
map ((String
"-X" forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> String
display) forall a b. (a -> b) -> a -> b
$ BuildInfo -> [Extension]
P.usedExtensions BuildInfo
binfo
libs :: [String]
libs = forall a b. (a -> b) -> [a] -> [b]
map (String
"-l" forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ BuildInfo -> [String]
P.extraLibs BuildInfo
binfo
cabalCppOptions :: FilePath -> IO [String]
cabalCppOptions :: String -> IO [String]
cabalCppOptions String
dir = do
Bool
exist <- String -> IO Bool
doesFileExist String
cabalMacro
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
exist then
[String
"-include", String
cabalMacro]
else
[]
where
cabalMacro :: String
cabalMacro = String
dir String -> String -> String
</> String
"dist/build/autogen/cabal_macros.h"
cabalAllBuildInfo :: PackageDescription -> [BuildInfo]
cabalAllBuildInfo :: PackageDescription -> [BuildInfo]
cabalAllBuildInfo PackageDescription
pd = [BuildInfo]
libBI forall a. [a] -> [a] -> [a]
++ [BuildInfo]
subBI forall a. [a] -> [a] -> [a]
++ [BuildInfo]
execBI forall a. [a] -> [a] -> [a]
++ [BuildInfo]
testBI forall a. [a] -> [a] -> [a]
++ [BuildInfo]
benchBI
where
libBI :: [BuildInfo]
libBI = forall a b. (a -> b) -> [a] -> [b]
map Library -> BuildInfo
P.libBuildInfo forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ PackageDescription -> Maybe Library
P.library PackageDescription
pd
subBI :: [BuildInfo]
subBI = forall a b. (a -> b) -> [a] -> [b]
map Library -> BuildInfo
P.libBuildInfo forall a b. (a -> b) -> a -> b
$ PackageDescription -> [Library]
P.subLibraries PackageDescription
pd
execBI :: [BuildInfo]
execBI = forall a b. (a -> b) -> [a] -> [b]
map Executable -> BuildInfo
P.buildInfo forall a b. (a -> b) -> a -> b
$ PackageDescription -> [Executable]
P.executables PackageDescription
pd
testBI :: [BuildInfo]
testBI = forall a b. (a -> b) -> [a] -> [b]
map TestSuite -> BuildInfo
P.testBuildInfo forall a b. (a -> b) -> a -> b
$ PackageDescription -> [TestSuite]
P.testSuites PackageDescription
pd
benchBI :: [BuildInfo]
benchBI = forall a b. (a -> b) -> [a] -> [b]
map Benchmark -> BuildInfo
P.benchmarkBuildInfo forall a b. (a -> b) -> a -> b
$ PackageDescription -> [Benchmark]
P.benchmarks PackageDescription
pd
cabalDependPackages :: [BuildInfo] -> [PackageBaseName]
cabalDependPackages :: [BuildInfo] -> [String]
cabalDependPackages [BuildInfo]
bis = [String] -> [String]
uniqueAndSort [String]
pkgs
where
pkgs :: [String]
pkgs = forall a b. (a -> b) -> [a] -> [b]
map Dependency -> String
getDependencyPackageName forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BuildInfo -> [Dependency]
P.targetBuildDepends [BuildInfo]
bis
getDependencyPackageName :: Dependency -> String
getDependencyPackageName (Dependency PackageName
pkg VersionRange
_ NonEmptySet LibraryName
_) = PackageName -> String
unPackageName PackageName
pkg
cabalSourceDirs :: [BuildInfo] -> [IncludeDir]
cabalSourceDirs :: [BuildInfo] -> [String]
cabalSourceDirs [BuildInfo]
bis = [String] -> [String]
uniqueAndSort forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map forall from to. SymbolicPath from to -> String
toPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildInfo -> [SymbolicPath PackageDir SourceDir]
P.hsSourceDirs) [BuildInfo]
bis
uniqueAndSort :: [String] -> [String]
uniqueAndSort :: [String] -> [String]
uniqueAndSort = forall a. Set a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
fromList
getGHCId :: IO CompilerId
getGHCId :: IO CompilerId
getGHCId = CompilerFlavor -> Version -> CompilerId
CompilerId CompilerFlavor
GHC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Version
getGHC
getGHC :: IO Version
getGHC :: IO Version
getGHC = do
Maybe Version
mv <- Program -> Verbosity -> String -> IO (Maybe Version)
programFindVersion Program
ghcProgram Verbosity
silent (Program -> String
programName Program
ghcProgram)
case Maybe Version
mv of
Maybe Version
Nothing -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"ghc not found"
Just Version
v -> forall (m :: * -> *) a. Monad m => a -> m a
return Version
v
cabalAllTargets :: PackageDescription -> IO ([String],[String],[String],[String])
cabalAllTargets :: PackageDescription -> IO ([String], [String], [String], [String])
cabalAllTargets PackageDescription
pd = do
[[String]]
exeTargets <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Executable -> IO [String]
getExecutableTarget forall a b. (a -> b) -> a -> b
$ PackageDescription -> [Executable]
P.executables PackageDescription
pd
[[String]]
testTargets <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TestSuite -> IO [String]
getTestTarget forall a b. (a -> b) -> a -> b
$ PackageDescription -> [TestSuite]
P.testSuites PackageDescription
pd
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
libTargets,forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
exeTargets,forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
testTargets,[String]
benchTargets)
where
lib :: [ModuleName]
lib = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Library -> [ModuleName]
P.explicitLibModules forall a b. (a -> b) -> a -> b
$ PackageDescription -> Maybe Library
P.library PackageDescription
pd
libTargets :: [String]
libTargets = forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> String
toModuleString [ModuleName]
lib
benchTargets :: [String]
benchTargets = forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> String
toModuleString forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Benchmark -> [ModuleName]
P.benchmarkModules forall a b. (a -> b) -> a -> b
$ PackageDescription -> [Benchmark]
P.benchmarks PackageDescription
pd
toModuleString :: ModuleName -> String
toModuleString :: ModuleName -> String
toModuleString ModuleName
mn = String -> String
fromFilePath forall a b. (a -> b) -> a -> b
$ ModuleName -> String
toFilePath ModuleName
mn
fromFilePath :: FilePath -> String
fromFilePath :: String -> String
fromFilePath String
fp = forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
cforall a. Eq a => a -> a -> Bool
==Char
'/' then Char
'.' else Char
c) String
fp
getTestTarget :: TestSuite -> IO [String]
getTestTarget :: TestSuite -> IO [String]
getTestTarget TestSuite
ts =
case TestSuite -> TestSuiteInterface
P.testInterface TestSuite
ts of
(TestSuiteExeV10 Version
_ String
filePath) -> do
let maybeTests :: [String]
maybeTests = [forall from to. SymbolicPath from to -> String
toPath SymbolicPath PackageDir SourceDir
p String -> String -> String
</> String
e | SymbolicPath PackageDir SourceDir
p <- BuildInfo -> [SymbolicPath PackageDir SourceDir]
P.hsSourceDirs forall a b. (a -> b) -> a -> b
$ TestSuite -> BuildInfo
P.testBuildInfo TestSuite
ts, String
e <- [String
filePath]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
maybeTests
(TestSuiteLibV09 Version
_ ModuleName
moduleName) -> forall (m :: * -> *) a. Monad m => a -> m a
return [ModuleName -> String
toModuleString ModuleName
moduleName]
(TestSuiteUnsupported TestType
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return []
getExecutableTarget :: Executable -> IO [String]
getExecutableTarget :: Executable -> IO [String]
getExecutableTarget Executable
exe = do
let maybeExes :: [String]
maybeExes = [forall from to. SymbolicPath from to -> String
toPath SymbolicPath PackageDir SourceDir
p String -> String -> String
</> String
e | SymbolicPath PackageDir SourceDir
p <- BuildInfo -> [SymbolicPath PackageDir SourceDir]
P.hsSourceDirs forall a b. (a -> b) -> a -> b
$ Executable -> BuildInfo
P.buildInfo Executable
exe, String
e <- [Executable -> String
P.modulePath Executable
exe]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
maybeExes
#if MIN_VERSION_Cabal(3,6,0)
toPath :: SymbolicPath from to -> FilePath
toPath :: forall from to. SymbolicPath from to -> String
toPath = forall from to. SymbolicPath from to -> String
getSymbolicPath
#else
toPath :: String -> String
toPath = id
#endif