{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.HaskellSuite where
import Prelude ()
import Distribution.Compat.Prelude
import qualified Data.List.NonEmpty as NE
import Distribution.Simple.Program
import Distribution.Simple.Compiler
import Distribution.Simple.Utils
import Distribution.Simple.BuildPaths
import Distribution.Verbosity
import Distribution.Version
import Distribution.Pretty
import Distribution.Parsec (simpleParsec)
import Distribution.Package
import Distribution.InstalledPackageInfo hiding (includeDirs)
import Distribution.Simple.PackageIndex as PackageIndex
import Distribution.PackageDescription
import Distribution.Simple.LocalBuildInfo
import Distribution.System (Platform)
import Distribution.Utils.Path
import Language.Haskell.Extension
import Distribution.Simple.Program.Builtin
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
String
hcPath <-
let msg :: String
msg = String
"You have to provide name or path of a haskell-suite tool (-w PATH)"
in forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
msg) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
mbHcPath
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe String
hcPkgPath) forall a b. (a -> b) -> a -> b
$
Verbosity -> String -> IO ()
warn Verbosity
verbosity String
"--with-hc-pkg option is ignored for haskell-suite"
(Compiler
comp, ConfiguredProgram
confdCompiler, ProgramDb
progdb1) <- String -> ProgramDb -> IO (Compiler, ConfiguredProgram, ProgramDb)
configureCompiler String
hcPath ProgramDb
progdb0
(ConfiguredProgram
confdPkg, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
haskellSuitePkgProgram ProgramDb
progdb1
let progdb2 :: ProgramDb
progdb2 =
ConfiguredProgram -> ProgramDb -> ProgramDb
updateProgram
ConfiguredProgram
confdPkg
{ programLocation :: ProgramLocation
programLocation = ConfiguredProgram -> ProgramLocation
programLocation ConfiguredProgram
confdCompiler
, programDefaultArgs :: [String]
programDefaultArgs = [String
"pkg"]
}
ProgramDb
progdb1
forall (m :: * -> *) a. Monad m => a -> m a
return (Compiler
comp, forall a. Maybe a
Nothing, ProgramDb
progdb2)
where
configureCompiler :: String -> ProgramDb -> IO (Compiler, ConfiguredProgram, ProgramDb)
configureCompiler String
hcPath ProgramDb
progdb0' = do
let
haskellSuiteProgram' :: Program
haskellSuiteProgram' =
Program
haskellSuiteProgram
{ programFindLocation :: Verbosity -> ProgramSearchPath -> IO (Maybe (String, [String]))
programFindLocation = \Verbosity
v ProgramSearchPath
p -> Verbosity
-> ProgramSearchPath -> String -> IO (Maybe (String, [String]))
findProgramOnSearchPath Verbosity
v ProgramSearchPath
p String
hcPath }
ProgramDb
progdb1 <- Verbosity -> Program -> ProgramDb -> IO ProgramDb
configureProgram Verbosity
verbosity Program
haskellSuiteProgram' ProgramDb
progdb0'
(ConfiguredProgram
confdCompiler, ProgramDb
progdb2) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
haskellSuiteProgram' ProgramDb
progdb1
[(Extension, Maybe String)]
extensions <- Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe String)]
getExtensions Verbosity
verbosity ConfiguredProgram
confdCompiler
[(Language, String)]
languages <- Verbosity -> ConfiguredProgram -> IO [(Language, String)]
getLanguages Verbosity
verbosity ConfiguredProgram
confdCompiler
(String
compName, Version
compVersion) <-
Verbosity -> ConfiguredProgram -> IO (String, Version)
getCompilerVersion Verbosity
verbosity ConfiguredProgram
confdCompiler
let
comp :: Compiler
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 = forall a. Monoid a => a
mempty
}
forall (m :: * -> *) a. Monad m => a -> m a
return (Compiler
comp, ConfiguredProgram
confdCompiler, ProgramDb
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" 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" (forall a. a -> Maybe a -> a
fromMaybe String
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
safeLast 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
String
output <- forall mode.
KnownIODataMode mode =>
Verbosity -> String -> [String] -> IO mode
rawSystemStdout Verbosity
verbosity (ConfiguredProgram -> String
programPath ConfiguredProgram
prog) [String
"--compiler-version"]
let
parts :: [String]
parts = String -> [String]
words String
output
name :: String
name = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
safeInit [String]
parts
versionStr :: String
versionStr = forall a. a -> Maybe a -> a
fromMaybe String
"" forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
safeLast [String]
parts
Version
version <-
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"haskell-suite: couldn't determine compiler version") forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall a. Parsec a => String -> Maybe a
simpleParsec String
versionStr
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, Version
version)
getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe CompilerFlag)]
getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe String)]
getExtensions Verbosity
verbosity ConfiguredProgram
prog = do
[String]
extStrs <-
String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
forall mode.
KnownIODataMode mode =>
Verbosity -> String -> [String] -> IO mode
rawSystemStdout Verbosity
verbosity (ConfiguredProgram -> String
programPath ConfiguredProgram
prog) [String
"--supported-extensions"]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ (Extension
ext, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"-X" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow Extension
ext) | Just Extension
ext <- forall a b. (a -> b) -> [a] -> [b]
map forall a. Parsec a => String -> Maybe a
simpleParsec [String]
extStrs ]
getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, CompilerFlag)]
getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, String)]
getLanguages Verbosity
verbosity ConfiguredProgram
prog = do
[String]
langStrs <-
String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
forall mode.
KnownIODataMode mode =>
Verbosity -> String -> [String] -> IO mode
rawSystemStdout Verbosity
verbosity (ConfiguredProgram -> String
programPath ConfiguredProgram
prog) [String
"--supported-languages"]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ (Language
ext, String
"-G" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow Language
ext) | Just Language
ext <- forall a b. (a -> b) -> [a] -> [b]
map forall a. Parsec a => String -> Maybe a
simpleParsec [String]
langStrs ]
getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages :: Verbosity
-> PackageDBStack -> ProgramDb -> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity PackageDBStack
packagedbs ProgramDb
progdb =
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([InstalledPackageInfo] -> InstalledPackageIndex
PackageIndex.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for PackageDBStack
packagedbs forall a b. (a -> b) -> a -> b
$ \PackageDB
packagedb ->
do String
str <-
Verbosity -> Program -> ProgramDb -> [String] -> IO String
getDbProgramOutput Verbosity
verbosity Program
haskellSuitePkgProgram ProgramDb
progdb
[String
"dump", PackageDB -> String
packageDbOpt PackageDB
packagedb]
forall a. IO a -> (ExitCode -> IO a) -> IO a
`catchExit` \ExitCode
_ -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"pkg dump failed"
case String -> Either [String] [InstalledPackageInfo]
parsePackages String
str of
Right [InstalledPackageInfo]
ok -> forall (m :: * -> *) a. Monad m => a -> m a
return [InstalledPackageInfo]
ok
Either [String] [InstalledPackageInfo]
_ -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"failed to parse output of 'pkg dump'"
where
parsePackages :: String -> Either [String] [InstalledPackageInfo]
parsePackages String
str =
case forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ByteString
-> Either (NonEmpty String) ([String], InstalledPackageInfo)
parseInstalledPackageInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
toUTF8BS) (String -> [String]
splitPkgs String
str) of
([], [([String], InstalledPackageInfo)]
ok) -> forall a b. b -> Either a b
Right [ InstalledPackageInfo
pkg | ([String]
_, InstalledPackageInfo
pkg) <- [([String], InstalledPackageInfo)]
ok ]
([NonEmpty String]
msgss, [([String], InstalledPackageInfo)]
_) -> forall a b. a -> Either a b
Left (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. NonEmpty a -> [a]
NE.toList [NonEmpty String]
msgss)
splitPkgs :: String -> [String]
splitPkgs :: String -> [String]
splitPkgs = forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [[a]]
splitWith (String
"---" forall a. Eq a => a -> a -> Bool
==) 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 forall a. a -> [a] -> [a]
: case [a]
zs of
[] -> []
a
_:[a]
ws -> forall a. (a -> Bool) -> [a] -> [[a]]
splitWith a -> Bool
p [a]
ws
where ([a]
ys,[a]
zs) = 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 = forall a b. (a -> b) -> [a] -> [b]
map forall from to. SymbolicPath from to -> String
getSymbolicPath (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
bi) forall a. [a] -> [a] -> [a]
++ [String
odir]
dbStack :: PackageDBStack
dbStack = LocalBuildInfo -> PackageDBStack
withPackageDB LocalBuildInfo
lbi
language :: 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 = forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg_descr
Verbosity -> Program -> ProgramDb -> [String] -> IO ()
runDbProgram Verbosity
verbosity Program
haskellSuiteProgram ProgramDb
progdb forall a b. (a -> b) -> a -> b
$
[ String
"compile", String
"--build-dir", String
odir ] forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [String
"-i", String
d] | String
d <- [String]
srcDirs ] forall a. [a] -> [a] -> [a]
++
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] forall a. [a] -> [a] -> [a]
++ BuildInfo -> [String]
includeDirs BuildInfo
bi ] forall a. [a] -> [a] -> [a]
++
[ PackageDB -> String
packageDbOpt PackageDB
pkgDb | PackageDB
pkgDb <- PackageDBStack
dbStack ] forall a. [a] -> [a] -> [a]
++
[ String
"--package-name", forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pkgid ] forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [String
"--package-id", forall a. Pretty a => a -> String
prettyShow UnitId
ipkgid ]
| (UnitId
ipkgid, MungedPackageId
_) <- ComponentLocalBuildInfo -> [(UnitId, MungedPackageId)]
componentPackageDeps ComponentLocalBuildInfo
clbi ] forall a. [a] -> [a] -> [a]
++
[String
"-G", forall a. Pretty a => a -> String
prettyShow Language
language] forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [String
"-X", forall a. Pretty a => a -> String
prettyShow Extension
ex] | Extension
ex <- BuildInfo -> [Extension]
usedExtensions BuildInfo
bi ] forall a. [a] -> [a] -> [a]
++
BuildInfo -> [String]
cppOptions (Library -> BuildInfo
libBuildInfo Library
lib) forall a. [a] -> [a] -> [a]
++
[ 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 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", forall a. Pretty a => a -> String
prettyShow forall a b. (a -> b) -> a -> b
$ forall pkg. Package pkg => pkg -> PackageIdentifier
packageId PackageDescription
pkg
] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map 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
(ConfiguredProgram
hspkg, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
haskellSuitePkgProgram ProgramDb
progdb
Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
(ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
hspkg
[String
"update", PackageDB -> String
packageDbOpt forall a b. (a -> b) -> a -> b
$ PackageDBStack -> PackageDB
registrationPackageDB PackageDBStack
packageDbs])
{ progInvokeInput :: Maybe IOData
progInvokeInput = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> IOData
IODataText forall a b. (a -> b) -> a -> b
$ InstalledPackageInfo -> String
showInstalledPackageInfo InstalledPackageInfo
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=" forall a. [a] -> [a] -> [a]
++ String
db