{-# LANGUAGE TupleSections, TypeApplications #-}
module NgxExport.Distribution (
buildSharedLib
,patchAndCollectDependentLibs
,ngxExportHooks
,defaultMain
) where
import Distribution.Simple hiding (defaultMain)
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Builtin
import Distribution.Simple.Program.Run
import Distribution.Simple.Program.Db
import Distribution.Simple.Setup
import Distribution.Simple.Utils
import Distribution.Types.PackageDescription
import Distribution.Types.BuildInfo
import Distribution.Types.Library
import Distribution.Verbosity
import Distribution.Pretty
import System.Directory
import System.FilePath
import Control.Arrow
import Control.Monad
import Data.Maybe
type GhcInfo = [(String, String)]
nhmTool :: Program
nhmTool :: Program
nhmTool = String -> Program
simpleProgram String
"nhm-tool"
patchelf :: Program
patchelf :: Program
patchelf = String -> Program
simpleProgram String
"patchelf"
buildSharedLib :: Verbosity
-> PackageDescription
-> LocalBuildInfo
-> BuildFlags
-> IO FilePath
buildSharedLib :: Verbosity
-> PackageDescription -> LocalBuildInfo -> BuildFlags -> IO String
buildSharedLib Verbosity
verbosity PackageDescription
desc LocalBuildInfo
lbi BuildFlags
flags = do
let configGhcOptions :: GhcInfo
configGhcOptions =
GhcInfo -> ([String] -> GhcInfo) -> Maybe [String] -> GhcInfo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((String -> (String, String)) -> [String] -> GhcInfo
forall a b. (a -> b) -> [a] -> [b]
map (String
"ghc", )) (Maybe [String] -> GhcInfo) -> Maybe [String] -> GhcInfo
forall a b. (a -> b) -> a -> b
$
CompilerFlavor -> [(CompilerFlavor, [String])] -> Maybe [String]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CompilerFlavor
GHC ([(CompilerFlavor, [String])] -> Maybe [String])
-> [(CompilerFlavor, [String])] -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ PerCompilerFlavor [String] -> [(CompilerFlavor, [String])]
forall v. PerCompilerFlavor v -> [(CompilerFlavor, v)]
perCompilerFlavorToList (PerCompilerFlavor [String] -> [(CompilerFlavor, [String])])
-> PerCompilerFlavor [String] -> [(CompilerFlavor, [String])]
forall a b. (a -> b) -> a -> b
$
BuildInfo -> PerCompilerFlavor [String]
options (BuildInfo -> PerCompilerFlavor [String])
-> BuildInfo -> PerCompilerFlavor [String]
forall a b. (a -> b) -> a -> b
$ Library -> BuildInfo
libBuildInfo (Library -> BuildInfo) -> Library -> BuildInfo
forall a b. (a -> b) -> a -> b
$ Maybe Library -> Library
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Library -> Library) -> Maybe Library -> Library
forall a b. (a -> b) -> a -> b
$ PackageDescription -> Maybe Library
library PackageDescription
desc
lib :: Maybe String
lib = (Maybe String, Bool) -> Maybe String
forall a b. (a, b) -> a
fst ((Maybe String, Bool) -> Maybe String)
-> (Maybe String, Bool) -> Maybe String
forall a b. (a -> b) -> a -> b
$
((Maybe String, Bool)
-> (String, [String]) -> (Maybe String, Bool))
-> (Maybe String, Bool)
-> [(String, [String])]
-> (Maybe String, Bool)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\a :: (Maybe String, Bool)
a@(Maybe String
r, Bool
_) (String
prog, [String]
v) ->
if String
prog String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"ghc" Bool -> Bool -> Bool
|| Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
r
then (Maybe String, Bool)
a
else ((Maybe String, Bool) -> String -> (Maybe String, Bool))
-> (Maybe String, Bool) -> [String] -> (Maybe String, Bool)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\a' :: (Maybe String, Bool)
a'@(Maybe String
r', Bool
ready) String
v' ->
if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
r'
then (Maybe String, Bool)
a'
else if String
v' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-o"
then (Maybe String
forall a. Maybe a
Nothing, Bool
True)
else if Bool
ready
then (String -> Maybe String
forall a. a -> Maybe a
Just String
v', Bool
False)
else (Maybe String
forall a. Maybe a
Nothing, Bool
False)
) (Maybe String, Bool)
a [String]
v
) (Maybe String
forall a. Maybe a
Nothing, Bool
False) ([(String, [String])] -> (Maybe String, Bool))
-> [(String, [String])] -> (Maybe String, Bool)
forall a b. (a -> b) -> a -> b
$
BuildFlags -> [(String, [String])]
buildProgramArgs BuildFlags
flags [(String, [String])]
-> [(String, [String])] -> [(String, [String])]
forall a. [a] -> [a] -> [a]
++
((String, String) -> (String, [String]))
-> GhcInfo -> [(String, [String])]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> [String]) -> (String, String) -> (String, [String])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) GhcInfo
configGhcOptions
(String
lib', [String]
extraGhcOptions) =
(String, [String])
-> (String -> (String, [String]))
-> Maybe String
-> (String, [String])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (let name :: String
name = PackageName -> String
unPackageName (PackageName -> String) -> PackageName -> String
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
package PackageDescription
desc
nameSo :: String
nameSo = String
name String -> String -> String
<.> String
"so"
in (String
nameSo, [String
name String -> String -> String
<.> String
"hs", String
"-o", String
nameSo])
) (, []) Maybe String
lib
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extraGhcOptions) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let extraSourceFile :: String
extraSourceFile = [String] -> String
forall a. HasCallStack => [a] -> a
head [String]
extraGhcOptions
Bool
extraSourceFileExists <- String -> IO Bool
doesFileExist String
extraSourceFile
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
extraSourceFileExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"File " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
extraSourceFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not exist, \
\you may want to specify input and output files in --ghc-options"
ConfiguredProgram
ghcP <- (ConfiguredProgram, ProgramDb) -> ConfiguredProgram
forall a b. (a, b) -> a
fst ((ConfiguredProgram, ProgramDb) -> ConfiguredProgram)
-> IO (ConfiguredProgram, ProgramDb) -> IO ConfiguredProgram
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
let libGhcOptions :: [String]
libGhcOptions = [String
"-dynamic", String
"-shared", String
"-fPIC"]
libGhcOptions' :: [String]
libGhcOptions' = if ConfiguredProgram -> Maybe Version
programVersion ConfiguredProgram
ghcP Maybe Version -> Maybe Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version -> Maybe Version
forall a. a -> Maybe a
Just ([Int] -> Version
mkVersion [Int
9, Int
0, Int
1])
then String
"-flink-rts" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
libGhcOptions
else [String]
libGhcOptions
ghcR :: ProgramInvocation
ghcR = ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
ghcP ([String] -> ProgramInvocation) -> [String] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
[String]
libGhcOptions' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String, String) -> String) -> GhcInfo -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> b
snd GhcInfo
configGhcOptions [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extraGhcOptions
Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity ProgramInvocation
ghcR
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
lib'
patchAndCollectDependentLibs :: Verbosity
-> FilePath
-> PackageDescription
-> LocalBuildInfo
-> IO ()
patchAndCollectDependentLibs :: Verbosity
-> String -> PackageDescription -> LocalBuildInfo -> IO ()
patchAndCollectDependentLibs Verbosity
verbosity String
lib PackageDescription
desc LocalBuildInfo
lbi = do
let dir :: String
dir = String -> (PathTemplate -> String) -> Maybe PathTemplate -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"unspecified-abi" PathTemplate -> String
fromPathTemplate (Maybe PathTemplate -> String) -> Maybe PathTemplate -> String
forall a b. (a -> b) -> a -> b
$ PathTemplateVariable
-> [(PathTemplateVariable, PathTemplate)] -> Maybe PathTemplate
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup PathTemplateVariable
AbiVar ([(PathTemplateVariable, PathTemplate)] -> Maybe PathTemplate)
-> [(PathTemplateVariable, PathTemplate)] -> Maybe PathTemplate
forall a b. (a -> b) -> a -> b
$
CompilerInfo -> Platform -> [(PathTemplateVariable, PathTemplate)]
abiTemplateEnv (Compiler -> CompilerInfo
compilerInfo (Compiler -> CompilerInfo) -> Compiler -> CompilerInfo
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi) (Platform -> [(PathTemplateVariable, PathTemplate)])
-> Platform -> [(PathTemplateVariable, PathTemplate)]
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
dirArg :: [String]
dirArg = String
"-d" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String
dir]
rpathArg :: [String]
rpathArg = [String]
-> (PathTemplate -> [String]) -> Maybe PathTemplate -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((String
"-t" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String])
-> (PathTemplate -> [String]) -> PathTemplate -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String])
-> (PathTemplate -> String) -> PathTemplate -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
</> String
dir) (String -> String)
-> (PathTemplate -> String) -> PathTemplate -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathTemplate -> String
fromPathTemplate) (Maybe PathTemplate -> [String]) -> Maybe PathTemplate -> [String]
forall a b. (a -> b) -> a -> b
$
Flag PathTemplate -> Maybe PathTemplate
forall a. Flag a -> Maybe a
flagToMaybe (Flag PathTemplate -> Maybe PathTemplate)
-> Flag PathTemplate -> Maybe PathTemplate
forall a b. (a -> b) -> a -> b
$ InstallDirs (Flag PathTemplate) -> Flag PathTemplate
forall dir. InstallDirs dir -> dir
prefix (InstallDirs (Flag PathTemplate) -> Flag PathTemplate)
-> InstallDirs (Flag PathTemplate) -> Flag PathTemplate
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> InstallDirs (Flag PathTemplate)
configInstallDirs (ConfigFlags -> InstallDirs (Flag PathTemplate))
-> ConfigFlags -> InstallDirs (Flag PathTemplate)
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> ConfigFlags
configFlags LocalBuildInfo
lbi
archiveArg :: [String]
archiveArg = String
"-a" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> String) -> PackageIdentifier -> String
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
package PackageDescription
desc]
ConfiguredProgram
ghcP <- (ConfiguredProgram, ProgramDb) -> ConfiguredProgram
forall a b. (a, b) -> a
fst ((ConfiguredProgram, ProgramDb) -> ConfiguredProgram)
-> IO (ConfiguredProgram, ProgramDb) -> IO ConfiguredProgram
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
let ghcR :: ProgramInvocation
ghcR = ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
ghcP [String
"--info"]
Bool
useLibFFI <- (String -> Maybe String
forall a. a -> Maybe a
Just String
"YES" Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe String -> Bool)
-> (String -> Maybe String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GhcInfo -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Use LibFFI" (GhcInfo -> Maybe String)
-> (String -> GhcInfo) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> a
read @GhcInfo (String -> Bool) -> IO String -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity ProgramInvocation
ghcR
ConfiguredProgram
nhmToolP <- (ConfiguredProgram, ProgramDb) -> ConfiguredProgram
forall a b. (a, b) -> a
fst ((ConfiguredProgram, ProgramDb) -> ConfiguredProgram)
-> IO (ConfiguredProgram, ProgramDb) -> IO ConfiguredProgram
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
nhmTool (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
let nhmToolArgs :: [String]
nhmToolArgs = [String]
rpathArg [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
dirArg [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
archiveArg
nhmToolR :: ProgramInvocation
nhmToolR = ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation ConfiguredProgram
nhmToolP ([String] -> ProgramInvocation) -> [String] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
String
"dist" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
lib String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"-v" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: if Bool
useLibFFI
then String
"-ffi" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
nhmToolArgs
else [String]
nhmToolArgs
Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity ProgramInvocation
nhmToolR
ngxExportHooks :: UserHooks
ngxExportHooks :: UserHooks
ngxExportHooks =
UserHooks
simpleUserHooks { hookedPrograms = [nhmTool]
, confHook = \(GenericPackageDescription, HookedBuildInfo)
desc ConfigFlags
flags -> do
let verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
toVerbosity (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
flags
pdb :: ProgramDb
pdb = WithCallStack (ConfigFlags -> ProgramDb)
ConfigFlags -> ProgramDb
configPrograms ConfigFlags
flags
(ConfiguredProgram, ProgramDb)
_ <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
nhmTool ProgramDb
pdb IO (ConfiguredProgram, ProgramDb)
-> ((ConfiguredProgram, ProgramDb)
-> IO (ConfiguredProgram, ProgramDb))
-> IO (ConfiguredProgram, ProgramDb)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
patchelf (ProgramDb -> IO (ConfiguredProgram, ProgramDb))
-> ((ConfiguredProgram, ProgramDb) -> ProgramDb)
-> (ConfiguredProgram, ProgramDb)
-> IO (ConfiguredProgram, ProgramDb)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConfiguredProgram, ProgramDb) -> ProgramDb
forall a b. (a, b) -> b
snd
UserHooks
-> (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags
-> IO LocalBuildInfo
confHook UserHooks
simpleUserHooks (GenericPackageDescription, HookedBuildInfo)
desc ConfigFlags
flags
, buildHook = \PackageDescription
desc LocalBuildInfo
lbi UserHooks
_ BuildFlags
flags -> do
let verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
toVerbosity (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ BuildFlags -> Flag Verbosity
buildVerbosity BuildFlags
flags
Verbosity
-> PackageDescription -> LocalBuildInfo -> BuildFlags -> IO String
buildSharedLib Verbosity
verbosity PackageDescription
desc LocalBuildInfo
lbi BuildFlags
flags IO String -> (String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
lib ->
Verbosity
-> String -> PackageDescription -> LocalBuildInfo -> IO ()
patchAndCollectDependentLibs Verbosity
verbosity String
lib PackageDescription
desc LocalBuildInfo
lbi
}
where toVerbosity :: Flag Verbosity -> Verbosity
toVerbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal
defaultMain :: IO ()
defaultMain :: IO ()
defaultMain = UserHooks -> IO ()
defaultMainWithHooks UserHooks
ngxExportHooks