{-# LANGUAGE DerivingStrategies #-}

-- | Internal utilities
module Distribution.Simple.GResource.Internal
  ( GResourceConfig (..),
    GResourceDependenciesCmd (..),
    GResourceCmd (..),
    GResource,
    xmlFilesField,
    sourceDirField,
    parseGResourceConfig,
    generatedCFile,
    gResourceCName,
    addCSources,
    runGResourceCmd,
    runGresourceGenerateDependencies,
  )
where

import Data.Maybe (fromMaybe)
import Distribution.Compat.Binary
import Distribution.Simple.Program (ConfiguredProgram, getProgramInvocationOutput, runProgramInvocation)
import Distribution.Simple.Program.Run (programInvocationCwd)
import Distribution.Simple.Utils (createDirectoryIfMissingVerbose)
import Distribution.Types.BuildInfo (BuildInfo (..))
import Distribution.Utils.Path
  ( CWD,
    FileOrDir (Dir, File),
    Pkg,
    Source,
    RelativePath,
    SymbolicPath,
    interpretSymbolicPath,
    interpretSymbolicPathCWD,
    makeRelativePathEx,
    makeSymbolicPath,
    takeDirectorySymbolicPath,
    (</>), replaceExtensionSymbolicPath, Build, getSymbolicPath,
  )
import Distribution.Verbosity (VerbosityFlags, defaultVerbosityHandles, mkVerbosity)
import GHC.Generics (Generic)
import qualified System.FilePath as FilePath

-- | Key for GResource XML manifest.
xmlFilesField :: String
xmlFilesField :: String
xmlFilesField = String
"x-gresource-xml-file"

-- | Key for GResource source directory
sourceDirField :: String
sourceDirField :: String
sourceDirField = String
"x-gresource-source-dir"

-- | GResource configuration.
data GResourceConfig = GResourceConfig
  { -- | XML manifest path.
    GResourceConfig -> SymbolicPathX 'OnlyRelative Source 'File
gresourceXml :: RelativePath Source File,
    -- | The @--sourcedir@ passed to @glib-compile-resources@.
    GResourceConfig
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir GResource)
gresourceSource :: SymbolicPath Pkg (Dir GResource)
  }

-- | Find custom fields and construct t'GResourceConfig'
parseGResourceConfig :: [(String, String)] -> Maybe GResourceConfig
parseGResourceConfig :: [(String, String)] -> Maybe GResourceConfig
parseGResourceConfig [(String, String)]
fields = do
  xmlFile <- String -> SymbolicPathX 'OnlyRelative Source 'File
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx (String -> SymbolicPathX 'OnlyRelative Source 'File)
-> Maybe String -> Maybe (SymbolicPathX 'OnlyRelative Source 'File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
xmlFilesField [(String, String)]
fields
  let srcDir = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
sourceDirField [(String, String)]
fields)
  pure
    GResourceConfig
      { gresourceXml = xmlFile,
        gresourceSource = makeSymbolicPath srcDir
      }

generatedCFile ::
  SymbolicPath Pkg (Dir Build) ->
  String ->
  RelativePath Source File ->
  SymbolicPath Pkg File
generatedCFile :: SymbolicPath Pkg ('Dir Build)
-> String
-> SymbolicPathX 'OnlyRelative Source 'File
-> SymbolicPathX 'AllowAbsolute Pkg 'File
generatedCFile SymbolicPath Pkg ('Dir Build)
baseDir String
componentName SymbolicPathX 'OnlyRelative Source 'File
xml =
  SymbolicPath Pkg ('Dir Build)
baseDir SymbolicPath Pkg ('Dir Build)
-> SymbolicPathX 'OnlyRelative Build 'File
-> SymbolicPathX 'AllowAbsolute Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPathX 'OnlyRelative Build 'File
forall {a3}. SymbolicPathX 'OnlyRelative a3 'File
generatedCRel
  where
    cFileName :: SymbolicPathX 'OnlyRelative Source 'File
cFileName = SymbolicPathX 'OnlyRelative Source 'File
-> SymbolicPathX 'OnlyRelative Source 'File
gResourceCName SymbolicPathX 'OnlyRelative Source 'File
xml
    generatedCRel :: SymbolicPathX 'OnlyRelative a3 'File
generatedCRel = String -> RelativePath a3 ('Dir (ZonkAny 1))
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx String
componentName RelativePath a3 ('Dir (ZonkAny 1))
-> SymbolicPathX 'OnlyRelative (ZonkAny 1) 'File
-> SymbolicPathX 'OnlyRelative a3 'File
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath (ZonkAny 1) ('Dir Source)
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx String
"autogen" RelativePath (ZonkAny 1) ('Dir Source)
-> SymbolicPathX 'OnlyRelative Source 'File
-> SymbolicPathX 'OnlyRelative (ZonkAny 1) 'File
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPathX 'OnlyRelative Source 'File
cFileName

gResourceCName :: RelativePath Source File -> RelativePath Source File
gResourceCName :: SymbolicPathX 'OnlyRelative Source 'File
-> SymbolicPathX 'OnlyRelative Source 'File
gResourceCName SymbolicPathX 'OnlyRelative Source 'File
xml = String -> SymbolicPathX 'OnlyRelative Source 'File
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx (String -> SymbolicPathX 'OnlyRelative Source 'File)
-> String -> SymbolicPathX 'OnlyRelative Source 'File
forall a b. (a -> b) -> a -> b
$ String -> String
FilePath.takeFileName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ SymbolicPathX 'OnlyRelative Source 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath (SymbolicPathX 'OnlyRelative Source 'File -> String)
-> SymbolicPathX 'OnlyRelative Source 'File -> String
forall a b. (a -> b) -> a -> b
$ SymbolicPathX 'OnlyRelative Source 'File
xml SymbolicPathX 'OnlyRelative Source 'File
-> String -> SymbolicPathX 'OnlyRelative Source 'File
forall (allowAbsolute :: AllowAbsolute) from.
SymbolicPathX allowAbsolute from 'File
-> String -> SymbolicPathX allowAbsolute from 'File
`replaceExtensionSymbolicPath` String
"c"

addCSources :: [SymbolicPath Pkg File] -> BuildInfo -> BuildInfo
addCSources :: [SymbolicPathX 'AllowAbsolute Pkg 'File] -> BuildInfo -> BuildInfo
addCSources [SymbolicPathX 'AllowAbsolute Pkg 'File]
generated BuildInfo
bi = BuildInfo
bi {cSources = generated ++ cSources bi}

-- | Run parameters and environment for @glib-compile-resources@.
data GResourceCmd = GResourceCmd
  { -- | Resolved @glib-compile-resources@ executable.
    GResourceCmd -> ConfiguredProgram
gcProgram :: ConfiguredProgram,
    -- | Symbolic path to Pkg directory from CWD
    GResourceCmd -> Maybe (SymbolicPath CWD ('Dir Pkg))
gcPkgDirectory :: Maybe (SymbolicPath CWD (Dir Pkg)),
    -- | Symbolic path to directory passed as @--sourcedir@ parameter.
    GResourceCmd -> SymbolicPathX 'AllowAbsolute Pkg ('Dir GResource)
gcSourceDir :: SymbolicPath Pkg (Dir GResource),
    -- | Symbolic path to @autogen@ directory.
    GResourceCmd -> SymbolicPathX 'AllowAbsolute Pkg 'File
gcTarget :: SymbolicPath Pkg File,
    -- | Symbolic path to XML manifest file.
    GResourceCmd -> SymbolicPathX 'OnlyRelative Source 'File
gcXmlFile :: RelativePath Source File,
    -- | Verbosity flags for logging
    GResourceCmd -> VerbosityFlags
gcVerbosity :: VerbosityFlags
  }
  deriving stock (Int -> GResourceCmd -> String -> String
[GResourceCmd] -> String -> String
GResourceCmd -> String
(Int -> GResourceCmd -> String -> String)
-> (GResourceCmd -> String)
-> ([GResourceCmd] -> String -> String)
-> Show GResourceCmd
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GResourceCmd -> String -> String
showsPrec :: Int -> GResourceCmd -> String -> String
$cshow :: GResourceCmd -> String
show :: GResourceCmd -> String
$cshowList :: [GResourceCmd] -> String -> String
showList :: [GResourceCmd] -> String -> String
Show, (forall x. GResourceCmd -> Rep GResourceCmd x)
-> (forall x. Rep GResourceCmd x -> GResourceCmd)
-> Generic GResourceCmd
forall x. Rep GResourceCmd x -> GResourceCmd
forall x. GResourceCmd -> Rep GResourceCmd x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GResourceCmd -> Rep GResourceCmd x
from :: forall x. GResourceCmd -> Rep GResourceCmd x
$cto :: forall x. Rep GResourceCmd x -> GResourceCmd
to :: forall x. Rep GResourceCmd x -> GResourceCmd
Generic)
  deriving anyclass (Get GResourceCmd
[GResourceCmd] -> Put
GResourceCmd -> Put
(GResourceCmd -> Put)
-> Get GResourceCmd
-> ([GResourceCmd] -> Put)
-> Binary GResourceCmd
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: GResourceCmd -> Put
put :: GResourceCmd -> Put
$cget :: Get GResourceCmd
get :: Get GResourceCmd
$cputList :: [GResourceCmd] -> Put
putList :: [GResourceCmd] -> Put
Binary)

-- | Run t`GResourceCmd.
runGResourceCmd :: GResourceCmd -> IO ()
runGResourceCmd :: GResourceCmd -> IO ()
runGResourceCmd GResourceCmd
cmd = do
  let verbosity :: Verbosity
verbosity = VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles GResourceCmd
cmd.gcVerbosity
  Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose
    Verbosity
verbosity
    Bool
True
    (Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 0)) -> String
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPath GResourceCmd
cmd.gcPkgDirectory (SymbolicPathX 'AllowAbsolute Pkg 'File
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 0))
forall (allowAbsolute :: AllowAbsolute) from to'.
SymbolicPathX allowAbsolute from 'File
-> SymbolicPathX allowAbsolute from ('Dir to')
takeDirectorySymbolicPath GResourceCmd
cmd.gcTarget))
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity (ProgramInvocation -> IO ()) -> ProgramInvocation -> IO ()
forall a b. (a -> b) -> a -> b
$
    Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [String] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [String] -> ProgramInvocation
programInvocationCwd
      GResourceCmd
cmd.gcPkgDirectory
      (GResourceCmd -> ConfiguredProgram
gcProgram GResourceCmd
cmd)
      [ String
"--generate-source",
        String
"--target=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SymbolicPathX 'AllowAbsolute Pkg 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPathCWD GResourceCmd
cmd.gcTarget,
        String
"--sourcedir=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SymbolicPathX 'AllowAbsolute Pkg ('Dir GResource) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPathCWD GResourceCmd
cmd.gcSourceDir,
        SymbolicPathX 'OnlyRelative Source 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPathCWD GResourceCmd
cmd.gcXmlFile
      ]

-- | Dependency query command parameters and environment for @glib-compile-resources@
data GResourceDependenciesCmd = GResourceDependenciesCmd
  { -- | Configured @glib-compile-resources@ executable.
    GResourceDependenciesCmd -> ConfiguredProgram
gdcProgram :: ConfiguredProgram,
    -- | Symbolic path to Pkg directory from CWD
    GResourceDependenciesCmd -> Maybe (SymbolicPath CWD ('Dir Pkg))
gdcPkgDirectory :: Maybe (SymbolicPath CWD (Dir Pkg)),
    -- | Symbolic path to directory passed as @--sourcedir@ parameter.
    GResourceDependenciesCmd
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir GResource)
gdcSourceDir :: SymbolicPath Pkg (Dir GResource),
    -- | Relative path to the XML manifest file.
    GResourceDependenciesCmd
-> SymbolicPathX 'OnlyRelative Source 'File
gdcXmlFile :: RelativePath Source File,
    -- | Verbosity flags for logging
    GResourceDependenciesCmd -> VerbosityFlags
gdcVerbosity :: VerbosityFlags
  }
  deriving stock (Int -> GResourceDependenciesCmd -> String -> String
[GResourceDependenciesCmd] -> String -> String
GResourceDependenciesCmd -> String
(Int -> GResourceDependenciesCmd -> String -> String)
-> (GResourceDependenciesCmd -> String)
-> ([GResourceDependenciesCmd] -> String -> String)
-> Show GResourceDependenciesCmd
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GResourceDependenciesCmd -> String -> String
showsPrec :: Int -> GResourceDependenciesCmd -> String -> String
$cshow :: GResourceDependenciesCmd -> String
show :: GResourceDependenciesCmd -> String
$cshowList :: [GResourceDependenciesCmd] -> String -> String
showList :: [GResourceDependenciesCmd] -> String -> String
Show, (forall x.
 GResourceDependenciesCmd -> Rep GResourceDependenciesCmd x)
-> (forall x.
    Rep GResourceDependenciesCmd x -> GResourceDependenciesCmd)
-> Generic GResourceDependenciesCmd
forall x.
Rep GResourceDependenciesCmd x -> GResourceDependenciesCmd
forall x.
GResourceDependenciesCmd -> Rep GResourceDependenciesCmd x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
GResourceDependenciesCmd -> Rep GResourceDependenciesCmd x
from :: forall x.
GResourceDependenciesCmd -> Rep GResourceDependenciesCmd x
$cto :: forall x.
Rep GResourceDependenciesCmd x -> GResourceDependenciesCmd
to :: forall x.
Rep GResourceDependenciesCmd x -> GResourceDependenciesCmd
Generic)
  deriving anyclass (Get GResourceDependenciesCmd
[GResourceDependenciesCmd] -> Put
GResourceDependenciesCmd -> Put
(GResourceDependenciesCmd -> Put)
-> Get GResourceDependenciesCmd
-> ([GResourceDependenciesCmd] -> Put)
-> Binary GResourceDependenciesCmd
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: GResourceDependenciesCmd -> Put
put :: GResourceDependenciesCmd -> Put
$cget :: Get GResourceDependenciesCmd
get :: Get GResourceDependenciesCmd
$cputList :: [GResourceDependenciesCmd] -> Put
putList :: [GResourceDependenciesCmd] -> Put
Binary)

-- | Run t'GResourceDependenciesCmd'
runGresourceGenerateDependencies :: GResourceDependenciesCmd -> IO [RelativePath Pkg File]
runGresourceGenerateDependencies :: GResourceDependenciesCmd -> IO [RelativePath Pkg 'File]
runGresourceGenerateDependencies GResourceDependenciesCmd
cmd = do
  let verbosity :: Verbosity
verbosity = VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles GResourceDependenciesCmd
cmd.gdcVerbosity
  dependencies <-
    Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput Verbosity
verbosity (ProgramInvocation -> IO String) -> ProgramInvocation -> IO String
forall a b. (a -> b) -> a -> b
$
      Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [String] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [String] -> ProgramInvocation
programInvocationCwd
        GResourceDependenciesCmd
cmd.gdcPkgDirectory
        GResourceDependenciesCmd
cmd.gdcProgram
        [ String
"--generate-dependencies",
          String
"--sourcedir=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SymbolicPathX 'AllowAbsolute Pkg ('Dir GResource) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPathCWD GResourceDependenciesCmd
cmd.gdcSourceDir,
          SymbolicPathX 'OnlyRelative Source 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPathCWD GResourceDependenciesCmd
cmd.gdcXmlFile
        ]
  pure (map makeRelativePathEx (lines dependencies))

--------------------------------------------------------------------------------
-- Abstract directory locations.

-- | Abstract directory: GResource source directory.
data GResource