{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StaticPointers #-}

-- | Integration for @build-type: Hooks@ builds.
module Distribution.Simple.GResource.Hooks
  ( gResourceSetupHooks,
  )
where

import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import qualified Data.List.NonEmpty as NE
import Data.String (fromString)
import Distribution.Simple.GResource.Internal
  ( GResourceCmd (..),
    GResourceConfig (..),
    GResourceDependenciesCmd (..),
    gResourceCName,
    parseGResourceConfig,
    runGResourceCmd,
    runGresourceGenerateDependencies,
  )
import Distribution.Simple.Program (requireProgram)
import Distribution.Simple.SetupHooks
import Distribution.Types.LocalBuildInfo (buildDirPBD)
import Distribution.Types.UnqualComponentName (unUnqualComponentName)
import Distribution.Utils.Path
  ( FileOrDir (Dir),
    SymbolicPath,
  )
import Distribution.Types.ComponentName (componentNameString)

-- | Hook for building the GResource files with @build-type: Hooks@.
-- Use in @SetupHooks.hs@ to integrate into the build process.
--
-- @
-- module SetupHooks (setupHooks) where
--
-- import Distribution.Simple.GResource.Hooks (gResourceSetupHooks)
-- import Distribution.Simple.SetupHooks (SetupHooks)
--
-- setupHooks :: SetupHooks
-- setupHooks = gResourceSetupHooks
-- @
--
-- Add @cabal-gresource@ to @setup-depends@:
--
-- @
-- build-type: Hooks
--
-- custom-setup
--   setup-depends:
--     base,
--     Cabal-hooks,
--     cabal-gresource
--
-- executable application:
--   ...
--   x-gresource-xml-file: resource/resource.xml
--   x-gresource-source-dir: resource
-- @
--
-- @since 0.1.0.0
gResourceSetupHooks :: SetupHooks
gResourceSetupHooks :: SetupHooks
gResourceSetupHooks =
  SetupHooks
noSetupHooks
    { configureHooks =
        noConfigureHooks {preConfComponentHook = Just gResourcePreConf},
      buildHooks =
        noBuildHooks {preBuildComponentRules = Just (rules (static ()) gResourceRules)}
    }

gResourceComponent :: Component -> Maybe (String, GResourceConfig)
gResourceComponent :: Component -> Maybe (String, GResourceConfig)
gResourceComponent Component
comp = do
  name <- Component -> Maybe String
compName Component
comp
  cfg <- parseGResourceConfig (customFieldsBI (componentBuildInfo comp))
  pure (name, cfg)

compName :: Component -> Maybe String
compName :: Component -> Maybe String
compName Component
comp = UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String)
-> Maybe UnqualComponentName -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ComponentName -> Maybe UnqualComponentName
componentNameString (ComponentName -> Maybe UnqualComponentName)
-> (Component -> ComponentName)
-> Component
-> Maybe UnqualComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Component -> ComponentName
componentName) Component
comp

autogenDirPBD :: PackageBuildDescr -> String -> SymbolicPath Pkg (Dir b)
autogenDirPBD :: forall b. PackageBuildDescr -> String -> SymbolicPath Pkg ('Dir b)
autogenDirPBD PackageBuildDescr
pbd String
name =
  PackageBuildDescr -> SymbolicPath Pkg ('Dir Build)
buildDirPBD PackageBuildDescr
pbd SymbolicPath Pkg ('Dir Build)
-> SymbolicPathX 'OnlyRelative Build ('Dir b)
-> SymbolicPath Pkg ('Dir b)
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Build ('Dir (ZonkAny 0))
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx String
name RelativePath Build ('Dir (ZonkAny 0))
-> RelativePath (ZonkAny 0) ('Dir b)
-> SymbolicPathX 'OnlyRelative Build ('Dir b)
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath (ZonkAny 0) ('Dir b)
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx String
"autogen"

gResourcePreConf :: PreConfComponentInputs -> IO PreConfComponentOutputs
gResourcePreConf :: PreConfComponentHook
gResourcePreConf inputs :: PreConfComponentInputs
inputs@(PreConfComponentInputs LocalBuildConfig
_lbc PackageBuildDescr
pbd Component
comp) =
  case Component -> Maybe (String, GResourceConfig)
gResourceComponent Component
comp of
    Maybe (String, GResourceConfig)
Nothing -> PreConfComponentOutputs -> IO PreConfComponentOutputs
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PreConfComponentInputs -> PreConfComponentOutputs
noPreConfComponentOutputs PreConfComponentInputs
inputs)
    Just (String
name, GResourceConfig
cfg) ->
      let cFilePath :: SymbolicPathX 'AllowAbsolute Pkg 'File
cFilePath = PackageBuildDescr -> String -> SymbolicPath Pkg ('Dir Source)
forall b. PackageBuildDescr -> String -> SymbolicPath Pkg ('Dir b)
autogenDirPBD PackageBuildDescr
pbd String
name SymbolicPath Pkg ('Dir Source)
-> RelativePath Source 'File
-> SymbolicPathX 'AllowAbsolute Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
</> RelativePath Source 'File -> RelativePath Source 'File
gResourceCName (GResourceConfig -> RelativePath Source 'File
gresourceXml GResourceConfig
cfg)
       in PreConfComponentOutputs -> IO PreConfComponentOutputs
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PreConfComponentOutputs -> IO PreConfComponentOutputs)
-> (ComponentDiff -> PreConfComponentOutputs)
-> ComponentDiff
-> IO PreConfComponentOutputs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentDiff -> PreConfComponentOutputs
PreConfComponentOutputs (ComponentDiff -> IO PreConfComponentOutputs)
-> ComponentDiff -> IO PreConfComponentOutputs
forall a b. (a -> b) -> a -> b
$
            ComponentName -> BuildInfo -> ComponentDiff
buildInfoComponentDiff
              (Component -> ComponentName
componentName Component
comp)
              (BuildInfo
emptyBuildInfo {cSources = [cFilePath]})

gResourceRules :: PreBuildComponentInputs -> RulesM ()
gResourceRules :: PreBuildComponentInputs -> RulesM ()
gResourceRules (PreBuildComponentInputs BuildingWhat
what LocalBuildInfo
lbi TargetInfo
tgt) =
  case Component -> Maybe (String, GResourceConfig)
gResourceComponent Component
comp of
    Maybe (String, GResourceConfig)
Nothing -> () -> RulesM ()
forall a. a -> RulesT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (String
name, GResourceConfig
cfg) -> do
      (prog, _) <-
        IO (ConfiguredProgram, ProgramDb)
-> RulesT IO (ConfiguredProgram, ProgramDb)
forall a. IO a -> RulesT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ConfiguredProgram, ProgramDb)
 -> RulesT IO (ConfiguredProgram, ProgramDb))
-> IO (ConfiguredProgram, ProgramDb)
-> RulesT IO (ConfiguredProgram, ProgramDb)
forall a b. (a -> b) -> a -> b
$
          Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity (String -> Program
simpleProgram String
"glib-compile-resources") (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
      let autogenDir = LocalBuildInfo
-> ComponentLocalBuildInfo -> SymbolicPath Pkg ('Dir Source)
autogenComponentModulesDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
          xml = GResourceConfig -> RelativePath Source 'File
gresourceXml GResourceConfig
cfg
          srcDir = GResourceConfig -> SymbolicPath Pkg ('Dir GResource)
gresourceSource GResourceConfig
cfg
          cName = RelativePath Source 'File -> RelativePath Source 'File
gResourceCName RelativePath Source 'File
xml
          depsArgs =
            GResourceDependenciesCmd
              { gdcProgram :: ConfiguredProgram
gdcProgram = ConfiguredProgram
prog,
                gdcPkgDirectory :: Maybe (SymbolicPath CWD ('Dir Pkg))
gdcPkgDirectory = Maybe (SymbolicPath CWD ('Dir Pkg))
pkgDir,
                gdcSourceDir :: SymbolicPath Pkg ('Dir GResource)
gdcSourceDir = GResourceConfig -> SymbolicPath Pkg ('Dir GResource)
gresourceSource GResourceConfig
cfg,
                gdcXmlFile :: RelativePath Source 'File
gdcXmlFile = RelativePath Source 'File
xml,
                gdcVerbosity :: VerbosityFlags
gdcVerbosity = VerbosityFlags
verbosityFlags
              }
          genArgs =
            GResourceCmd
              { gcProgram :: ConfiguredProgram
gcProgram = ConfiguredProgram
prog,
                gcPkgDirectory :: Maybe (SymbolicPath CWD ('Dir Pkg))
gcPkgDirectory = Maybe (SymbolicPath CWD ('Dir Pkg))
pkgDir,
                gcSourceDir :: SymbolicPath Pkg ('Dir GResource)
gcSourceDir = GResourceConfig -> SymbolicPath Pkg ('Dir GResource)
gresourceSource GResourceConfig
cfg,
                gcTarget :: SymbolicPathX 'AllowAbsolute Pkg 'File
gcTarget = SymbolicPath Pkg ('Dir Source)
autogenDir SymbolicPath Pkg ('Dir Source)
-> RelativePath Source 'File
-> SymbolicPathX 'AllowAbsolute Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
</> RelativePath Source 'File
cName,
                gcXmlFile :: RelativePath Source 'File
gcXmlFile = RelativePath Source 'File
xml,
                gcVerbosity :: VerbosityFlags
gcVerbosity = VerbosityFlags
verbosityFlags
              }

          dependencyAction :: GResourceDependenciesCmd -> IO ([Dependency], ())
          dependencyAction GResourceDependenciesCmd
cmd = do
            dependencies <- GResourceDependenciesCmd -> IO [RelativePath Pkg 'File]
runGresourceGenerateDependencies GResourceDependenciesCmd
cmd
            pure ([FileDependency $ Location sameDirectory dep | dep <- dependencies], ())

          generateAction :: GResourceCmd -> () -> IO ()
          generateAction GResourceCmd
cmd () = GResourceCmd -> IO ()
runGResourceCmd GResourceCmd
cmd

          depsCmd = StaticPtr
  (Dict
     (Binary GResourceDependenciesCmd, Show GResourceDependenciesCmd))
-> StaticPtr (GResourceDependenciesCmd -> IO ([Dependency], ()))
-> GResourceDependenciesCmd
-> Command GResourceDependenciesCmd (IO ([Dependency], ()))
forall arg res.
StaticPtr (Dict (Binary arg, Show arg))
-> StaticPtr (arg -> res) -> arg -> Command arg res
mkCommand (static Dict
  (Binary GResourceDependenciesCmd, Show GResourceDependenciesCmd)
forall (c :: Constraint). c => Dict c
Dict) (static GResourceDependenciesCmd -> IO ([Dependency], ())
dependencyAction) GResourceDependenciesCmd
depsArgs
          genCmd = StaticPtr (Dict (Binary GResourceCmd, Show GResourceCmd))
-> StaticPtr (GResourceCmd -> () -> IO ())
-> GResourceCmd
-> Command GResourceCmd (() -> IO ())
forall arg res.
StaticPtr (Dict (Binary arg, Show arg))
-> StaticPtr (arg -> res) -> arg -> Command arg res
mkCommand (static Dict (Binary GResourceCmd, Show GResourceCmd)
forall (c :: Constraint). c => Dict c
Dict) (static GResourceCmd -> () -> IO ()
generateAction) GResourceCmd
genArgs
          manifestDep = Location -> Dependency
FileDependency (SymbolicPath Pkg ('Dir Source)
-> RelativePath Source 'File -> Location
forall baseDir.
SymbolicPath Pkg ('Dir baseDir)
-> RelativePath baseDir 'File -> Location
Location SymbolicPath Pkg ('Dir Source)
forall (allowAbsolute :: AllowAbsolute) from to.
SymbolicPathX allowAbsolute from ('Dir to)
sameDirectory RelativePath Source 'File
xml)
          output = SymbolicPath Pkg ('Dir Source)
-> RelativePath Source 'File -> Location
forall baseDir.
SymbolicPath Pkg ('Dir baseDir)
-> RelativePath baseDir 'File -> Location
Location SymbolicPath Pkg ('Dir Source)
autogenDir RelativePath Source 'File
cName
      addRuleMonitors
        [ monitorFileOrDirectory (getSymbolicPath xml),
          monitorDirectory (getSymbolicPath srcDir)
        ]
      void $
        registerRule
          (fromString ("gresource-" ++ name))
          (dynamicRule (static Dict) depsCmd genCmd [manifestDep] (output NE.:| []))
  where
    comp :: Component
comp = TargetInfo -> Component
targetComponent TargetInfo
tgt
    clbi :: ComponentLocalBuildInfo
clbi = TargetInfo -> ComponentLocalBuildInfo
targetCLBI TargetInfo
tgt
    verbosityFlags :: VerbosityFlags
verbosityFlags = BuildingWhat -> VerbosityFlags
buildingWhatVerbosity BuildingWhat
what
    verbosity :: Verbosity
verbosity = VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles VerbosityFlags
verbosityFlags
    pkgDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
pkgDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi