{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.HaskellSuite where
import Distribution.Compat.Prelude
import Prelude ()
import qualified Data.List.NonEmpty as NE
import Distribution.InstalledPackageInfo hiding (includeDirs)
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Parsec (simpleParsec)
import Distribution.Pretty
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.Program
import Distribution.Simple.Program.Builtin
import Distribution.Simple.Utils
import Distribution.System (Platform)
import Distribution.Utils.Path
import Distribution.Verbosity
import Distribution.Version
import Language.Haskell.Extension
configure
:: Verbosity
-> Maybe FilePath
-> Maybe FilePath
-> ProgramDb
-> IO (Compiler, Maybe Platform, ProgramDb)
configure :: Verbosity
-> Maybe String
-> Maybe String
-> ProgramDb
-> IO (Compiler, Maybe Platform, ProgramDb)
configure Verbosity
verbosity Maybe String
mbHcPath Maybe String
hcPkgPath ProgramDb
progdb0 = do
hcPath <-
let msg :: String
msg = String
"You have to provide name or path of a haskell-suite tool (-w PATH)"
in IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Verbosity -> CabalException -> IO String
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO String) -> CabalException -> IO String
forall a b. (a -> b) -> a -> b
$ String -> CabalException
ProvideHaskellSuiteTool String
msg) String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
mbHcPath
when (isJust hcPkgPath) $
warn verbosity "--with-hc-pkg option is ignored for haskell-suite"
(comp, confdCompiler, progdb1) <- configureCompiler hcPath progdb0
(confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb1
let progdb2 =
ConfiguredProgram -> ProgramDb -> ProgramDb
updateProgram
ConfiguredProgram
confdPkg
{ programLocation = programLocation confdCompiler
, programDefaultArgs = ["pkg"]
}
ProgramDb
progdb1
return (comp, Nothing, progdb2)
where
configureCompiler :: String -> ProgramDb -> IO (Compiler, ConfiguredProgram, ProgramDb)
configureCompiler String
hcPath ProgramDb
progdb0' = do
let
haskellSuiteProgram' :: Program
haskellSuiteProgram' =
Program
haskellSuiteProgram
{ programFindLocation = \Verbosity
v ProgramSearchPath
p -> Verbosity
-> ProgramSearchPath -> String -> IO (Maybe (String, [String]))
findProgramOnSearchPath Verbosity
v ProgramSearchPath
p String
hcPath
}
progdb1 <- Verbosity -> Program -> ProgramDb -> IO ProgramDb
configureProgram Verbosity
verbosity Program
haskellSuiteProgram' ProgramDb
progdb0'
(confdCompiler, progdb2) <- requireProgram verbosity haskellSuiteProgram' progdb1
extensions <- getExtensions verbosity confdCompiler
languages <- getLanguages verbosity confdCompiler
(compName, compVersion) <-
getCompilerVersion verbosity confdCompiler
let
comp =
Compiler
{ compilerId :: CompilerId
compilerId = CompilerFlavor -> Version -> CompilerId
CompilerId (String -> CompilerFlavor
HaskellSuite String
compName) Version
compVersion
, compilerAbiTag :: AbiTag
compilerAbiTag = AbiTag
NoAbiTag
, compilerCompat :: [CompilerId]
compilerCompat = []
, compilerLanguages :: [(Language, String)]
compilerLanguages = [(Language, String)]
languages
, compilerExtensions :: [(Extension, Maybe String)]
compilerExtensions = [(Extension, Maybe String)]
extensions
, compilerProperties :: Map String String
compilerProperties = Map String String
forall a. Monoid a => a
mempty
}
return (comp, confdCompiler, progdb2)
hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version)
hstoolVersion :: Verbosity -> String -> IO (Maybe Version)
hstoolVersion = String
-> (String -> String) -> Verbosity -> String -> IO (Maybe Version)
findProgramVersion String
"--hspkg-version" String -> String
forall a. a -> a
id
numericVersion :: Verbosity -> FilePath -> IO (Maybe Version)
numericVersion :: Verbosity -> String -> IO (Maybe Version)
numericVersion = String
-> (String -> String) -> Verbosity -> String -> IO (Maybe Version)
findProgramVersion String
"--compiler-version" (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> (String -> Maybe String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Maybe String
forall a. [a] -> Maybe a
safeLast ([String] -> Maybe String)
-> (String -> [String]) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words)
getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version)
getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version)
getCompilerVersion Verbosity
verbosity ConfiguredProgram
prog = do
output <- Verbosity -> String -> [String] -> IO String
forall mode.
KnownIODataMode mode =>
Verbosity -> String -> [String] -> IO mode
rawSystemStdout Verbosity
verbosity (ConfiguredProgram -> String
programPath ConfiguredProgram
prog) [String
"--compiler-version"]
let
parts = String -> [String]
words String
output
name = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
safeInit [String]
parts
versionStr = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe String
forall a. [a] -> Maybe a
safeLast [String]
parts
version <-
maybe
(dieWithException verbosity CannotDetermineCompilerVersion)
return
$ simpleParsec versionStr
return (name, version)
getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe CompilerFlag)]
getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe String)]
getExtensions Verbosity
verbosity ConfiguredProgram
prog = do
extStrs <-
String -> [String]
lines
(String -> [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity -> String -> [String] -> IO String
forall mode.
KnownIODataMode mode =>
Verbosity -> String -> [String] -> IO mode
rawSystemStdout Verbosity
verbosity (ConfiguredProgram -> String
programPath ConfiguredProgram
prog) [String
"--supported-extensions"]
return
[(ext, Just $ "-X" ++ prettyShow ext) | Just ext <- map simpleParsec extStrs]
getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, CompilerFlag)]
getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, String)]
getLanguages Verbosity
verbosity ConfiguredProgram
prog = do
langStrs <-
String -> [String]
lines
(String -> [String]) -> IO String -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity -> String -> [String] -> IO String
forall mode.
KnownIODataMode mode =>
Verbosity -> String -> [String] -> IO mode
rawSystemStdout Verbosity
verbosity (ConfiguredProgram -> String
programPath ConfiguredProgram
prog) [String
"--supported-languages"]
return
[(ext, "-G" ++ prettyShow ext) | Just ext <- map simpleParsec langStrs]
getInstalledPackages
:: Verbosity
-> PackageDBStack
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages :: Verbosity
-> PackageDBStack -> ProgramDb -> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity PackageDBStack
packagedbs ProgramDb
progdb =
([[InstalledPackageInfo]] -> InstalledPackageIndex)
-> IO [[InstalledPackageInfo]] -> IO InstalledPackageIndex
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([InstalledPackageInfo] -> InstalledPackageIndex
PackageIndex.fromList ([InstalledPackageInfo] -> InstalledPackageIndex)
-> ([[InstalledPackageInfo]] -> [InstalledPackageInfo])
-> [[InstalledPackageInfo]]
-> InstalledPackageIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[InstalledPackageInfo]] -> [InstalledPackageInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (IO [[InstalledPackageInfo]] -> IO InstalledPackageIndex)
-> IO [[InstalledPackageInfo]] -> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$ PackageDBStack
-> (PackageDB -> IO [InstalledPackageInfo])
-> IO [[InstalledPackageInfo]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for PackageDBStack
packagedbs ((PackageDB -> IO [InstalledPackageInfo])
-> IO [[InstalledPackageInfo]])
-> (PackageDB -> IO [InstalledPackageInfo])
-> IO [[InstalledPackageInfo]]
forall a b. (a -> b) -> a -> b
$ \PackageDB
packagedb ->
do
str <-
Verbosity -> Program -> ProgramDb -> [String] -> IO String
getDbProgramOutput
Verbosity
verbosity
Program
haskellSuitePkgProgram
ProgramDb
progdb
[String
"dump", PackageDB -> String
packageDbOpt PackageDB
packagedb]
IO String -> (ExitCode -> IO String) -> IO String
forall a. IO a -> (ExitCode -> IO a) -> IO a
`catchExit` \ExitCode
_ -> Verbosity -> CabalException -> IO String
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
PkgDumpFailed
case parsePackages str of
Right [InstalledPackageInfo]
ok -> [InstalledPackageInfo] -> IO [InstalledPackageInfo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [InstalledPackageInfo]
ok
Either [String] [InstalledPackageInfo]
_ -> Verbosity -> CabalException -> IO [InstalledPackageInfo]
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
FailedToParseOutput
where
parsePackages :: String -> Either [String] [InstalledPackageInfo]
parsePackages String
str =
case [Either (NonEmpty String) ([String], InstalledPackageInfo)]
-> ([NonEmpty String], [([String], InstalledPackageInfo)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (NonEmpty String) ([String], InstalledPackageInfo)]
-> ([NonEmpty String], [([String], InstalledPackageInfo)]))
-> [Either (NonEmpty String) ([String], InstalledPackageInfo)]
-> ([NonEmpty String], [([String], InstalledPackageInfo)])
forall a b. (a -> b) -> a -> b
$ (String
-> Either (NonEmpty String) ([String], InstalledPackageInfo))
-> [String]
-> [Either (NonEmpty String) ([String], InstalledPackageInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString
-> Either (NonEmpty String) ([String], InstalledPackageInfo)
parseInstalledPackageInfo (ByteString
-> Either (NonEmpty String) ([String], InstalledPackageInfo))
-> (String -> ByteString)
-> String
-> Either (NonEmpty String) ([String], InstalledPackageInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
toUTF8BS) (String -> [String]
splitPkgs String
str) of
([], [([String], InstalledPackageInfo)]
ok) -> [InstalledPackageInfo] -> Either [String] [InstalledPackageInfo]
forall a b. b -> Either a b
Right [InstalledPackageInfo
pkg | ([String]
_, InstalledPackageInfo
pkg) <- [([String], InstalledPackageInfo)]
ok]
([NonEmpty String]
msgss, [([String], InstalledPackageInfo)]
_) -> [String] -> Either [String] [InstalledPackageInfo]
forall a b. a -> Either a b
Left ((NonEmpty String -> [String]) -> [NonEmpty String] -> [String]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList [NonEmpty String]
msgss)
splitPkgs :: String -> [String]
splitPkgs :: String -> [String]
splitPkgs = ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
unlines ([[String]] -> [String])
-> (String -> [[String]]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [[String]]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWith (String
"---" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) ([String] -> [[String]])
-> (String -> [String]) -> String -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
where
splitWith :: (a -> Bool) -> [a] -> [[a]]
splitWith :: forall a. (a -> Bool) -> [a] -> [[a]]
splitWith a -> Bool
p [a]
xs =
[a]
ys [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: case [a]
zs of
[] -> []
a
_ : [a]
ws -> (a -> Bool) -> [a] -> [[a]]
forall a. (a -> Bool) -> [a] -> [[a]]
splitWith a -> Bool
p [a]
ws
where
([a]
ys, [a]
zs) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break a -> Bool
p [a]
xs
buildLib
:: Verbosity
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO ()
buildLib :: Verbosity
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO ()
buildLib Verbosity
verbosity PackageDescription
pkg_descr LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi = do
let odir :: String
odir = LocalBuildInfo -> String
buildDir LocalBuildInfo
lbi
bi :: BuildInfo
bi = Library -> BuildInfo
libBuildInfo Library
lib
srcDirs :: [String]
srcDirs = (SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath PackageDir SourceDir -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
bi) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
odir]
dbStack :: PackageDBStack
dbStack = LocalBuildInfo -> PackageDBStack
withPackageDB LocalBuildInfo
lbi
language :: Language
language = Language -> Maybe Language -> Language
forall a. a -> Maybe a -> a
fromMaybe Language
Haskell98 (BuildInfo -> Maybe Language
defaultLanguage BuildInfo
bi)
progdb :: ProgramDb
progdb = LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi
pkgid :: PackageIdentifier
pkgid = PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr
Verbosity -> Program -> ProgramDb -> [String] -> IO ()
runDbProgram Verbosity
verbosity Program
haskellSuiteProgram ProgramDb
progdb ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
[String
"compile", String
"--build-dir", String
odir]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String
"-i", String
d] | String
d <- [String]
srcDirs]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"-I", String
d]
| String
d <-
[ LocalBuildInfo -> ComponentLocalBuildInfo -> String
autogenComponentModulesDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
, LocalBuildInfo -> String
autogenPackageModulesDir LocalBuildInfo
lbi
, String
odir
]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [String]
includeDirs BuildInfo
bi
]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [PackageDB -> String
packageDbOpt PackageDB
pkgDb | PackageDB
pkgDb <- PackageDBStack
dbStack]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--package-name", PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgid]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"--package-id", UnitId -> String
forall a. Pretty a => a -> String
prettyShow UnitId
ipkgid]
| (UnitId
ipkgid, MungedPackageId
_) <- ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)]
componentPackageDeps ComponentLocalBuildInfo
clbi
]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-G", Language -> String
forall a. Pretty a => a -> String
prettyShow Language
language]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String
"-X", Extension -> String
forall a. Pretty a => a -> String
prettyShow Extension
ex] | Extension
ex <- BuildInfo -> [Extension]
usedExtensions BuildInfo
bi]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [String]
cppOptions (Library -> BuildInfo
libBuildInfo Library
lib)
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
modu | ModuleName
modu <- Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi]
installLib
:: Verbosity
-> LocalBuildInfo
-> FilePath
-> FilePath
-> FilePath
-> PackageDescription
-> Library
-> ComponentLocalBuildInfo
-> IO ()
installLib :: Verbosity
-> LocalBuildInfo
-> String
-> String
-> String
-> PackageDescription
-> Library
-> ComponentLocalBuildInfo
-> IO ()
installLib Verbosity
verbosity LocalBuildInfo
lbi String
targetDir String
dynlibTargetDir String
builtDir PackageDescription
pkg Library
lib ComponentLocalBuildInfo
clbi = do
let progdb :: ProgramDb
progdb = LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi
Verbosity -> Program -> ProgramDb -> [String] -> IO ()
runDbProgram Verbosity
verbosity Program
haskellSuitePkgProgram ProgramDb
progdb ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
[ String
"install-library"
, String
"--build-dir"
, String
builtDir
, String
"--target-dir"
, String
targetDir
, String
"--dynlib-target-dir"
, String
dynlibTargetDir
, String
"--package-id"
, PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> String) -> PackageIdentifier -> String
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg
]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (ModuleName -> String) -> [ModuleName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> String
forall a. Pretty a => a -> String
prettyShow (Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi)
registerPackage
:: Verbosity
-> ProgramDb
-> PackageDBStack
-> InstalledPackageInfo
-> IO ()
registerPackage :: Verbosity
-> ProgramDb -> PackageDBStack -> InstalledPackageInfo -> IO ()
registerPackage Verbosity
verbosity ProgramDb
progdb PackageDBStack
packageDbs InstalledPackageInfo
installedPkgInfo = do
(hspkg, _) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
haskellSuitePkgProgram ProgramDb
progdb
runProgramInvocation verbosity $
( programInvocation
hspkg
["update", packageDbOpt $ registrationPackageDB packageDbs]
)
{ progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo
}
initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO ()
initPackageDB :: Verbosity -> ProgramDb -> String -> IO ()
initPackageDB Verbosity
verbosity ProgramDb
progdb String
dbPath =
Verbosity -> Program -> ProgramDb -> [String] -> IO ()
runDbProgram
Verbosity
verbosity
Program
haskellSuitePkgProgram
ProgramDb
progdb
[String
"init", String
dbPath]
packageDbOpt :: PackageDB -> String
packageDbOpt :: PackageDB -> String
packageDbOpt PackageDB
GlobalPackageDB = String
"--global"
packageDbOpt PackageDB
UserPackageDB = String
"--user"
packageDbOpt (SpecificPackageDB String
db) = String
"--package-db=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
db