-- This is the default, but we have to instruct the formatter used on the repo:
{-# LANGUAGE NoImportQualifiedPost #-}

-- |
--
--  Example:
--
--  @
--      main :: IO ()
--      main =
--        defaultMainWithHooks $
--          simpleUserHooks
--            & addHook
--              (mkSettings "nix-store")
--                { macroName = "NIX",
--                  flagPrefixName = "nix"
--                }
--  @
--
--  The above will look for a pkg-config package @nix-store@, and then
--
--    * Define CPP, C and C++ macros
--
--        * @NIX_MAJOR@, an integer
--        * @NIX_MINOR@, an integer
--        * @NIX_PATCH@, an integer; 0 if missing
--        * @NIX_IS_AT_LEAST(major,minor,patch)@, returning true when the discovered version @>=@ the specified version
--
--    * Set or unset flags like `nix-2_4` so that the flag is true when the
--      discovered version is at least the version in the flag's name.
module Distribution.PkgConfigVersionHook
  ( addHook,
    mkSettings,
    Settings (..),
    composeConfHook,
  )
where

import Control.Lens ((%~), (^.))
import Control.Monad (when)
import qualified Data.Char as C
import Data.Foldable (toList)
import Data.Function ((&))
import qualified Data.List as L
import Distribution.Simple (UserHooks (confHook))
import Distribution.Simple.Setup (ConfigFlags, configConfigurationsFlags)
import Distribution.Types.BuildInfo.Lens (ccOptions, cppOptions, cxxOptions)
import Distribution.Types.Flag (flagName, mkFlagAssignment, mkFlagName, unFlagName)
import Distribution.Types.GenericPackageDescription.Lens
  ( GenericPackageDescription,
    condBenchmarks,
    condExecutables,
    condForeignLibs,
    condLibrary,
    condSubLibraries,
    condTestSuites,
    genPackageFlags,
  )
import System.IO (hPutStrLn, stderr)
import System.Process (readProcess)
import qualified Text.ParserCombinators.ReadP as P
import Prelude hiding (log)

-- | Hook into Cabal to provide pkg-config metadata. Can be applied multiple
-- times to support multiple packages.
addHook :: Settings -> UserHooks -> UserHooks
addHook :: Settings -> UserHooks -> UserHooks
addHook Settings
settings UserHooks
hooks = UserHooks
hooks {confHook :: (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags -> IO LocalBuildInfo
confHook = forall a b.
Settings
-> ((GenericPackageDescription, a) -> ConfigFlags -> IO b)
-> (GenericPackageDescription, a)
-> ConfigFlags
-> IO b
composeConfHook Settings
settings (UserHooks
-> (GenericPackageDescription, HookedBuildInfo)
-> ConfigFlags
-> IO LocalBuildInfo
confHook UserHooks
hooks)}

-- | How the metadata for a pkg-config package should be made available to the
-- cabal file.
data Settings = Settings
  { -- | Name of the package; used for querying pkg-config.
    Settings -> String
pkgConfigName :: String,
    -- | Name to use in the Haskell CPP and C/C++ preprocessor macros.
    --
    -- For example, `pkgConfigName = "FOO"` will set the macros
    --
    --  * @FOO_MAJOR@
    --
    --  * @FOO_MINOR@
    --
    --  * @FOO_PATCH@
    --
    --  * @FOO_IS_AT_LEAST(major, minor, patch)@
    Settings -> String
macroName :: String,
    -- | Name to use when setting flag values in the cabal file.
    --
    -- Flags named with this prefix, followed by a dash, followed by a major version number, an underscore and a minor version number will be set when the detected package is at least that version.
    Settings -> String
flagPrefixName :: String
  }

-- | Derive a default 'Settings' value from just a pkg-config package name.
mkSettings :: String -> Settings
mkSettings :: String -> Settings
mkSettings String
name =
  Settings
    { pkgConfigName :: String
pkgConfigName = String
name,
      macroName :: String
macroName = forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> case Char
c of Char
'-' -> Char
'_'; Char
x -> Char
x) String
name,
      flagPrefixName :: String
flagPrefixName = String
name
    }

-- | Extend the value of 'confHook'. It's what powers 'addHook'.
composeConfHook ::
  Settings ->
  ((GenericPackageDescription, a) -> ConfigFlags -> IO b) ->
  (GenericPackageDescription, a) ->
  Distribution.Simple.Setup.ConfigFlags ->
  IO b
composeConfHook :: forall a b.
Settings
-> ((GenericPackageDescription, a) -> ConfigFlags -> IO b)
-> (GenericPackageDescription, a)
-> ConfigFlags
-> IO b
composeConfHook Settings
settings (GenericPackageDescription, a) -> ConfigFlags -> IO b
origHook = \(GenericPackageDescription
genericPackageDescription, a
hookedBuildInfo) ConfigFlags
confFlags -> do
  (Int
actualMajor, Int
actualMinor, Int
actualPatch) <- String -> IO (Int, Int, Int)
getPkgConfigPackageVersion (Settings -> String
pkgConfigName Settings
settings)

  let defines :: [String]
defines =
        [ String
"-D" forall a. Semigroup a => a -> a -> a
<> Settings -> String
macroName Settings
settings forall a. Semigroup a => a -> a -> a
<> String
"_MAJOR=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
actualMajor,
          String
"-D" forall a. Semigroup a => a -> a -> a
<> Settings -> String
macroName Settings
settings forall a. Semigroup a => a -> a -> a
<> String
"_MINOR=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
actualMinor,
          String
"-D" forall a. Semigroup a => a -> a -> a
<> Settings -> String
macroName Settings
settings forall a. Semigroup a => a -> a -> a
<> String
"_PATCH=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
actualPatch,
          String
"-D" forall a. Semigroup a => a -> a -> a
<> Settings -> String
macroName Settings
settings forall a. Semigroup a => a -> a -> a
<> String
"_IS_AT_LEAST(a,b,c)=(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
actualMajor forall a. Semigroup a => a -> a -> a
<> String
">a||(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
actualMajor forall a. Semigroup a => a -> a -> a
<> String
"==a&&(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
actualMinor forall a. Semigroup a => a -> a -> a
<> String
">b||(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
actualMinor forall a. Semigroup a => a -> a -> a
<> String
"==b&&" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
actualPatch forall a. Semigroup a => a -> a -> a
<> String
">=c))))"
        ]
      extraFlags :: [(FlagName, Bool)]
extraFlags =
        [ (String -> FlagName
mkFlagName (Settings -> String
flagPrefixName Settings
settings forall a. [a] -> [a] -> [a]
++ String
"-" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
major forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
minor), (Int
actualMajor, Int
actualMinor) forall a. Ord a => a -> a -> Bool
>= (Int
major, Int
minor))
          | PackageFlag
declaredFlag <- GenericPackageDescription
genericPackageDescription forall s a. s -> Getting a s a -> a
^. Lens' GenericPackageDescription [PackageFlag]
genPackageFlags,
            let rawName :: String
rawName = FlagName -> String
unFlagName forall a b. (a -> b) -> a -> b
$ PackageFlag -> FlagName
flagName PackageFlag
declaredFlag,
            String
rawVersion <- forall a. Eq a => [a] -> [a] -> Maybe [a]
L.stripPrefix (Settings -> String
flagPrefixName Settings
settings forall a. [a] -> [a] -> [a]
++ String
"-") String
rawName forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) a. Foldable t => t a -> [a]
toList,
            [Int
major, Int
minor] <- forall a. ReadP a -> String -> Maybe a
unambiguously ReadP [Int]
parseFlagVersion String
rawVersion forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
        ]
      setDefines :: ((a -> Identity a) -> b -> Identity b) -> b -> b
setDefines (a -> Identity a) -> b -> Identity b
comp b
x =
        b
x
          forall a b. a -> (a -> b) -> b
& (a -> Identity a) -> b -> Identity b
comp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasBuildInfo a => Lens' a [String]
cppOptions forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> [String]
defines)
          forall a b. a -> (a -> b) -> b
& (a -> Identity a) -> b -> Identity b
comp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasBuildInfo a => Lens' a [String]
ccOptions forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> [String]
defines)
          forall a b. a -> (a -> b) -> b
& (a -> Identity a) -> b -> Identity b
comp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasBuildInfo a => Lens' a [String]
cxxOptions forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> [String]
defines)
      genericPackageDescription' :: GenericPackageDescription
genericPackageDescription' =
        GenericPackageDescription
genericPackageDescription
          forall a b. a -> (a -> b) -> b
& forall {a} {b}.
HasBuildInfo a =>
((a -> Identity a) -> b -> Identity b) -> b -> b
setDefines (Lens'
  GenericPackageDescription
  (Maybe (CondTree ConfVar [Dependency] Library))
condLibrary forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse)
          forall a b. a -> (a -> b) -> b
& forall {a} {b}.
HasBuildInfo a =>
((a -> Identity a) -> b -> Identity b) -> b -> b
setDefines (Lens'
  GenericPackageDescription
  [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condSubLibraries forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse)
          forall a b. a -> (a -> b) -> b
& forall {a} {b}.
HasBuildInfo a =>
((a -> Identity a) -> b -> Identity b) -> b -> b
setDefines (Lens'
  GenericPackageDescription
  [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
condForeignLibs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse)
          forall a b. a -> (a -> b) -> b
& forall {a} {b}.
HasBuildInfo a =>
((a -> Identity a) -> b -> Identity b) -> b -> b
setDefines (Lens'
  GenericPackageDescription
  [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
condExecutables forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse)
          forall a b. a -> (a -> b) -> b
& forall {a} {b}.
HasBuildInfo a =>
((a -> Identity a) -> b -> Identity b) -> b -> b
setDefines (Lens'
  GenericPackageDescription
  [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
condTestSuites forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse)
          forall a b. a -> (a -> b) -> b
& forall {a} {b}.
HasBuildInfo a =>
((a -> Identity a) -> b -> Identity b) -> b -> b
setDefines (Lens'
  GenericPackageDescription
  [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
condBenchmarks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse)

      configConfigurationsFlags' :: FlagAssignment
configConfigurationsFlags' = ConfigFlags -> FlagAssignment
configConfigurationsFlags ConfigFlags
confFlags forall a. Monoid a => a -> a -> a
`mappend` [(FlagName, Bool)] -> FlagAssignment
mkFlagAssignment [(FlagName, Bool)]
extraFlags
      confFlags' :: ConfigFlags
confFlags' =
        ConfigFlags
confFlags
          { configConfigurationsFlags :: FlagAssignment
configConfigurationsFlags = FlagAssignment
configConfigurationsFlags'
          }
  (GenericPackageDescription, a) -> ConfigFlags -> IO b
origHook (GenericPackageDescription
genericPackageDescription', a
hookedBuildInfo) ConfigFlags
confFlags'

parseVersion :: P.ReadP [Int]
parseVersion :: ReadP [Int]
parseVersion = do
  forall a b. (a -> b) -> [a] -> [b]
map forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    forall a. ReadP a -> ReadP [a]
P.many1 ((Char -> Bool) -> ReadP Char
P.satisfy Char -> Bool
C.isDigit) forall a sep. ReadP a -> ReadP sep -> ReadP [a]
`P.sepBy` Char -> ReadP Char
P.char Char
'.'

parseFlagVersion :: P.ReadP [Int]
parseFlagVersion :: ReadP [Int]
parseFlagVersion =
  forall a b. (a -> b) -> [a] -> [b]
map forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    forall a. ReadP a -> ReadP [a]
P.many1 ((Char -> Bool) -> ReadP Char
P.satisfy Char -> Bool
C.isDigit) forall a sep. ReadP a -> ReadP sep -> ReadP [a]
`P.sepBy` Char -> ReadP Char
P.char Char
'_'

unambiguously :: P.ReadP a -> String -> Maybe a
unambiguously :: forall a. ReadP a -> String -> Maybe a
unambiguously ReadP a
p String
s =
  case forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
_a, String
x) -> String
x forall a. Eq a => a -> a -> Bool
== String
"") forall a b. (a -> b) -> a -> b
$ forall a. ReadP a -> ReadS a
P.readP_to_S ReadP a
p String
s of
    [(a
v, String
_)] -> forall a. a -> Maybe a
Just a
v
    [(a, String)]
_ -> forall a. Maybe a
Nothing

getPkgConfigPackageVersion :: String -> IO (Int, Int, Int)
getPkgConfigPackageVersion :: String -> IO (Int, Int, Int)
getPkgConfigPackageVersion String
pkgName = do
  String
s <- String -> [String] -> String -> IO String
readProcess String
"pkg-config" [String
"--modversion", String
pkgName] String
""
  case forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (\([Int]
_, String
remainder) -> forall (t :: * -> *) a. Foldable t => t a -> Int
length String
remainder) forall a b. (a -> b) -> a -> b
$ forall a. ReadP a -> ReadS a
P.readP_to_S ReadP [Int]
parseVersion String
s of
    [] -> forall a. HasCallStack => String -> a
error (String
"Could not parse version " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s forall a. [a] -> [a] -> [a]
++ String
" returned by pkg-config for package " forall a. [a] -> [a] -> [a]
++ String
pkgName)
    ([Int]
v, String
r) : [([Int], String)]
_ -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. (a -> Bool) -> [a] -> [a]
L.dropWhile Char -> Bool
C.isSpace String
r forall a. Eq a => a -> a -> Bool
/= String
"") forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
log (String
"ignoring trailing text " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
r forall a. [a] -> [a] -> [a]
++ String
" in version " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s forall a. [a] -> [a] -> [a]
++ String
" of pkg-config package " forall a. [a] -> [a] -> [a]
++ String
pkgName)
      let v' :: [Int]
v' = [Int]
v forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
L.repeat Int
0
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Int]
v' forall a. [a] -> Int -> a
L.!! Int
0, [Int]
v' forall a. [a] -> Int -> a
L.!! Int
1, [Int]
v' forall a. [a] -> Int -> a
L.!! Int
2)

-- Should probably use a Cabal function?
log :: String -> IO ()
log :: String -> IO ()
log = Handle -> String -> IO ()
hPutStrLn Handle
stderr