{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StaticPointers #-}

{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

{-|
Module: Distribution.Simple.SetupHooks
Description: Interface for the @Hooks@ @build-type@.

This module defines the interface for the @Hooks@ @build-type@.

To write a package that implements @build-type: Hooks@, you should define
a module @SetupHooks.hs@ which exports a value @setupHooks :: 'SetupHooks'@.
This is a record that declares actions that should be hooked into the
cabal build process.

See also the introductory [how to guide](https://cabal.readthedocs.io/en/latest/how-to-use-setup-hooks.html)
in the Cabal user manual.
-}
module Distribution.Simple.SetupHooks
  ( -- * Hooks

    -- $setupHooks
    SetupHooks(..)
  , noSetupHooks

     -- * Usage overview
     -- $usage

     -- * Configure hooks

     -- $configureHooks
  , ConfigureHooks(..)
  , noConfigureHooks
    -- ** Per-package configure hooks
  , PreConfPackageInputs(..)
  , PreConfPackageOutputs(..) -- See Note [Not hiding SetupHooks constructors]
  , noPreConfPackageOutputs
  , PreConfPackageHook
  , PostConfPackageInputs(..)
  , PostConfPackageHook
    -- ** Per-component configure hooks
  , PreConfComponentInputs(..)
  , PreConfComponentOutputs(..) -- See Note [Not hiding SetupHooks constructors]
  , noPreConfComponentOutputs
  , PreConfComponentHook
  , ComponentDiff(..), emptyComponentDiff, buildInfoComponentDiff
  , LibraryDiff, ForeignLibDiff, ExecutableDiff
  , TestSuiteDiff, BenchmarkDiff
  , BuildInfoDiff

    -- * Build hooks

  , BuildHooks(..), noBuildHooks
  , BuildingWhat(..), buildingWhatVerbosity, buildingWhatDistPref

    -- ** Pre-build rules

    -- $preBuildRules
  , PreBuildComponentInputs(..)
  , PreBuildComponentRules

    -- ** Post-build hooks
  , PostBuildComponentInputs(..)
  , PostBuildComponentHook

    -- ** Rules
  , Rules
  , rules
  , noRules

    -- *** Rules API

    -- $rulesAPI
  , RulesM
    -- | Rule names (use @OverloadedStrings@ or 'Data.String.fromString')
  , ShortText
  , registerRule
  , registerRule_

    -- *** Rule construction
  , Rule
  , staticRule, dynamicRule

    -- **** Example usage of 'dynamicRule'
    -- $dynamicRules

    -- *** Rule inputs/outputs

    -- **** Rule dependencies
    -- $rulesDeps
  , Dependency (..)
  , RuleOutput (..)
  , RuleId

    -- **** Filesystem locations
  , Location(..)
  , location
  , autogenComponentModulesDir
  , componentBuildDir

    -- **** Path types and utilities
  , RelativePath
  , sameDirectory
  , getSymbolicPath
  , makeRelativePathEx
  , moduleNameSymbolicPath
  , FileLike(..)
  , PathLike(..)

    -- ***** Directory types
  , Source, Build, Pkg, CWD

    -- **** File search
  , findAndMonitorDirFileGlob
  , findAndMonitorSourceDirsFileExts

    -- ***** File globbing re-exports
  , Glob(..)
  , GlobPiece(..)
  , GlobSyntaxError(..)
  , parseFileGlob
  , globMatches
  , runDirFileGlob

    -- *** Actions
  , RuleCommands -- gnarly constructors not exposed; API is via 'staticRule' and 'dynamicRule'
  , Command
  , mkCommand
  , Dict(..)
    -- | Custom datatypes used as rule command arguments must implement
    -- serialisation. Derive these instances using @DeriveAnyClass@ and
    -- @DeriveGeneric@:
    --
    -- > data MyInput = MyInput { .. }
    -- >   deriving stock    ( Eq, Show, Generic )
    -- >   deriving anyclass Binary
  , Binary


  -- *** File/directory monitoring
  , addRuleMonitors
  , module Distribution.Simple.FileMonitor.Types

    -- * Install hooks
  , InstallHooks(..), noInstallHooks
  , InstallComponentInputs(..), InstallComponentHook

    -- * Re-exports

    -- ** Hooks
    -- *** Configure hooks
  , ConfigFlags(..)
    -- *** Build hooks
  , BuildFlags(..), ReplFlags(..), HaddockFlags(..), HscolourFlags(..)
    -- *** Install hooks
  , CopyFlags(..)

    -- ** @Hooks@ API
    --
    -- | These are functions provided as part of the @Hooks@ API.
    -- It is recommended to import them from this module as opposed to
    -- manually importing them from inside the Cabal module hierarchy.

    -- *** Copy/install functions
  , installFileGlob

    -- *** Interacting with the program database
  , Program(..), ConfiguredProgram(..), ProgArg
  , ProgramLocation(..)
  , ProgramDb
  , addKnownPrograms
  , configureUnconfiguredProgram
  , lookupProgram
  , lookupProgramByName
  , simpleProgram
  , runProgramCwd

    -- *** IO utilities
  , warn
  , createDirectoryIfMissingVerbose
  , rewriteFileEx

    -- ** General @Cabal@ datatypes
  , Compiler(..), Platform(..), Suffix(..)

    -- *** Verbosity
  , Verbosity, VerbosityFlags, VerbosityHandles
  , mkVerbosity, defaultVerbosityHandles

    -- *** Package information
  , LocalBuildConfig, LocalBuildInfo, PackageBuildDescr
      -- NB: we can't simply re-export all the fields of LocalBuildConfig etc,
      -- due to the presence of duplicate record fields.
      -- Ideally, we'd like to e.g. re-export LocalBuildConfig qualified,
      -- but qualified re-exports aren't a thing currently.

  , PackageDescription(..)

    -- **** LocalBuildInfo utilities
  , localPkgDescr
  , mbWorkDirLBI
  , withPrograms
  , interpretSymbolicPathLBI
  , componentBuildInfo

    -- *** Component information
  , Component(..), ComponentName(..), componentName
  , ModuleName
  , BuildInfo(..), emptyBuildInfo
  , TargetInfo(..), ComponentLocalBuildInfo(..)

    -- **** Components
  , Library(..), ForeignLib(..), Executable(..)
  , TestSuite(..), Benchmark(..)
  , LibraryName(..)
  , emptyLibrary, emptyForeignLib, emptyExecutable
  , emptyTestSuite, emptyBenchmark

  )
where
import Distribution.Compat.Binary
  ( Binary )
import Distribution.ModuleName
  ( ModuleName )
import Distribution.PackageDescription
  ( PackageDescription(..)
  , Library(..), ForeignLib(..)
  , Executable(..), TestSuite(..), Benchmark(..)
  , emptyLibrary, emptyForeignLib
  , emptyExecutable, emptyBenchmark, emptyTestSuite
  , BuildInfo(..), emptyBuildInfo
  , ComponentName(..), LibraryName(..)
  )
import Distribution.Simple.BuildPaths
  ( autogenComponentModulesDir )
import Distribution.Simple.Compiler
  ( Compiler(..) )
import Distribution.Simple.Errors
  ( CabalException(SetupHooksException)
  )
import Distribution.Simple.FileMonitor.Types
  hiding ( Glob )
import Distribution.Simple.Glob
  ( Glob, GlobSyntaxError(..)
  , globMatches, runDirFileGlob, parseFileGlob
  )
import Distribution.Simple.Glob.Internal
  ( Glob(..), GlobPiece(..)
  )
import Distribution.Simple.Install
  ( installFileGlob )
import Distribution.Simple.LocalBuildInfo
  ( componentBuildDir, componentBuildInfo
  , mbWorkDirLBI, interpretSymbolicPathLBI
  )
import Distribution.Simple.PreProcess.Types
  ( Suffix(..) )
import Distribution.Simple.Program
  ( runProgramCwd )
import Distribution.Simple.Program.Db
  ( ProgramDb, addKnownPrograms
  , configureUnconfiguredProgram
  , lookupProgram, lookupProgramByName
  )
import Distribution.Simple.Program.Find
  ( simpleProgram )
import Distribution.Simple.Program.Types
  ( Program(..), ConfiguredProgram(..)
  , ProgArg
  , ProgramLocation(..)
  )
import Distribution.Simple.Setup
  ( BuildFlags(..)
  , ConfigFlags(..)
  , CopyFlags(..)
  , HaddockFlags(..)
  , HscolourFlags(..)
  , ReplFlags(..)
  )
import Distribution.Simple.SetupHooks.Errors
import Distribution.Simple.SetupHooks.Internal
import Distribution.Simple.SetupHooks.Rule as Rule
import Distribution.Simple.Utils
  ( createDirectoryIfMissingVerbose
  , dieWithException
  , rewriteFileEx
  , warn
  )
import Distribution.System
  ( Platform(..) )
import Distribution.Types.Component
  ( Component(..), componentName )
import Distribution.Types.ComponentLocalBuildInfo
  ( ComponentLocalBuildInfo(..) )
import Distribution.Types.LocalBuildInfo
  ( LocalBuildInfo(..), withPrograms )
import Distribution.Types.LocalBuildConfig
  ( LocalBuildConfig, PackageBuildDescr )
import Distribution.Types.TargetInfo
  ( TargetInfo(..) )
import Distribution.Utils.Path
  ( SymbolicPath, CWD, Pkg, FileOrDir(..)
  , interpretSymbolicPath, makeRelativePathEx
  , RelativePath, Source, Build
  , getSymbolicPath, sameDirectory, moduleNameSymbolicPath
  , FileLike(..), PathLike(..)
  )
import Distribution.Utils.ShortText
  ( ShortText )
import Distribution.Verbosity
  ( Verbosity
  , VerbosityFlags, VerbosityHandles
  , mkVerbosity, defaultVerbosityHandles
  )

import Control.Monad
  ( void )
import Control.Monad.IO.Class
  ( MonadIO(liftIO) )
import Control.Monad.Trans.Class
  ( lift )
import qualified Control.Monad.Trans.Reader as Reader
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Writer.CPS as Writer
import qualified Data.List.NonEmpty as NE
import Data.Foldable
  ( for_ )
import Data.Traversable
  ( for )
import Data.Map.Strict as Map
  ( insertLookupWithKey )

--------------------------------------------------------------------------------
-- Haddocks for the SetupHooks API

{- $setupHooks
A Cabal package with @Hooks@ @build-type@ must define the Haskell module
@SetupHooks@ which defines a value @setupHooks :: 'SetupHooks'@.

These __setup hooks__ allow package authors to customise the configuration and
building of a package by providing certain hooks that get folded into the
general package configuration and building logic within @Cabal@.

This mechanism replaces the @Custom@ @build-type@, providing better
integration with the rest of the Haskell ecosystem.

Usage example:

> -- In your .cabal file
> build-type: Hooks
>
> custom-setup
>   setup-depends:
>     base        >= 4.18 && < 5,
>     Cabal-hooks >= 3.14 && < 3.15
>
> The declared Cabal version should also be at least 3.14.

> -- In SetupHooks.hs, next to your .cabal file
> module SetupHooks where
> import Distribution.Simple.SetupHooks ( SetupHooks, noSetupHooks )
>
> setupHooks :: SetupHooks
> setupHooks =
>  noSetupHooks
>    { configureHooks = myConfigureHooks
>    , buildHooks = myBuildHooks }

Note that 'SetupHooks' can be monoidally combined, e.g.:

> module SetupHooks where
> import Distribution.Simple.SetupHooks
> import qualified SomeOtherLibrary ( setupHooks )
>
> setupHooks :: SetupHooks
> setupHooks = SomeOtherLibrary.setupHooks <> mySetupHooks
>
> mySetupHooks :: SetupHooks
> mySetupHooks = ...
-}

{- $usage
'SetupHooks' allow hooks into the following phases:

  * The configure phase, via 'ConfigureHooks'.

      There are three hooks into the configure phase:

        * Package-wide pre-configure hook.

            This hook enables custom logic in the style of traditional @./configure@
            scripts, e.g. finding out information about the system and configuring
            dependencies.

        * Package-wide post-configure hook.

            This hook is mostly used to write write custom package-wide information
            to disk so that the next step can read it without repeating work.

        * Per-component pre-configure hooks.

            These hooks are used to modify individual components, e.g. declaring
            new modules (such as autogenerated modules whose module names are not
            statically known) or specifying per-component flags to be used when
            building each component.

            You can think of this step as dynamically updating the stanza for a
            single component in the .cabal file of a package.

  * The build phase, via 'BuildHooks'.

      There are two hooks into the build phase:

        * Per-component pre-build rules.

            A rule can be thought of an invocation of a code generator; each rule
            specifies how to build a particular output.

            You can have rules that don't depend on any inputs (e.g. directly
            generate a collection of modules programmatically, perhaps from some
            kind of parsed schema), as well as preprocessor-like rules that take in
            input files, e.g. the Happy parser generator that takes in a .y
            file and generates a corresponding .hs file.

            This rather elaborate setup (compared to a one-shot program that
            generates the required modules) allows proper recompilation checking.
            See also <https://well-typed.com/blog/2025/01/cabal-hooks/#pre-build-rules>
            for some worked examples of pre-build rules.

        * Per-component post-build hooks.

            These can be thought of as "pre-linking hooks" and allow injecting
            additional data into the final executable.

  * The install phase, via 'InstallHooks'.

      There is a single, per-component install hook. This allows copying over
      additional files when installing a component (library/executable).
-}

{- $configureHooks
Configure hooks can be used to augment the Cabal configure logic with
package-specific logic. The main principle is that the configure hooks can
feed into updating the 'PackageDescription' of a @cabal@ package. From then on,
this package configuration is set in stone, and later hooks (e.g. hooks into
the build phase) can no longer modify this configuration; instead they will
receive this configuration in their inputs, and must honour it.

Configuration happens at two levels:

  * global configuration covers the entire package,
  * local configuration covers a single component.

Once the global package configuration is done, all hooks work on a
per-component level. The configuration hooks thus follow a simple philosophy:

  * All modifications to global package options must use `preConfPackageHook`.
  * All modifications to component configuration options must use `preConfComponentHook`.

For example, to generate modules inside a given component, you should:

  * In the per-component configure hook, declare the modules you are going to
    generate by adding them to the `autogenModules` field for that component
    (unless you know them ahead of time, in which case they can be listed
    textually in the @.cabal@ file of the project).
  * In the build hooks, describe the actions that will generate these modules.
-}

{- $preBuildRules
Pre-build hooks are specified as a collection of pre-build 'Rules'.
Each t'Rule' consists of:

  - a specification of its static dependencies and outputs,
  - the commands that execute the rule.

You can think of a t'Rule' as describing a particular invocation of a code
generator or preprocessor, with the t'Command' specifying the particular
command that will be executed.

Rules are constructed using either one of the 'staticRule' or 'dynamicRule'
smart constructors. Directly constructing a t'Rule' using the constructors of
that data type is not advised, as this relies on internal implementation details
which are subject to change in between versions of the @Cabal-hooks@ library.

Note that:

  - To declare the dependency on the output of a rule, one must refer to the
    rule directly, and not to the path to the output executing that rule will
    eventually produce.

      This is achieved by using the t'RuleId' returned by 'registerRule', which
      is the unique identifier for that rule.

  - File dependencies and outputs are not specified directly by
    'FilePath', but rather use the 'Location' type (which is more convenient
    when working with preprocessors).
  - Rules refer to the actions that execute them using static pointers, in order
    to enable serialisation/deserialisation of rules.
  - Rules can additionally monitor files or directories, which determines
    when to re-compute the entire set of rules.
-}

{- $dynamicRules
The 'dynamicRule' smart constructor allows specifying rules that have dynamic
dependencies. This is the most complex part of the API, so let's work through
a representative example.

Suppose for example that we have preprocessor for files that may depend on
each other via explicit import statements at the start of the file. To properly
preprocess these, we need two commands:

  1. A "find dependencies" command that parses the header to find the dependencies.
  2. A "run preprocessor" command. This command might need to be passed the
     dependencies as arguments, so the command in (1) should make that information
     available to (2).

This is exactly what 'dynamicRule' allows us to do. The first command is (1),
which returns dynamic dependencies and additional data passed to the second
command, (2).

The rules for such a preprocessor would thus look something like (sketch):

@
ppDynPreBuildRules :: PreBuildComponentInputs -> RulesM ()
ppDynPreBuildRules pbci = mdo -- NB: using RecursiveDo

  -- Scan filesystem for files to preprocess, e.g. with a monitored file glob.
  inputModNms <- ...

  let

    -- (1): the "find dependencies" action
    computeDepsAction
      :: (Map ModuleName RuleId, FilePath)
      -> IO ([Dependency], [ModuleName])
    computeDepsAction (modNmToRuleId, inFile) = do
      src <- readFile inFile
      let dynDeps = parseHeaderImports src
      return
        ( [ RuleDependency $ RuleOutput rId 1
          | dep <- dynDeps
          , let rId = modNmToRuleId Map.! dep ]
        , dynDeps )

    -- (2): the "run preprocessor" action
    runPPAction :: (FilePath, FilePath) -> [ModuleName] -> IO ()
    runPPAction (inFile, outFile) dynDeps = do
      src <- readFile inFile
      let ppResult = preprocessWithDependencies dynDeps src
      writeFile outFile ppResult

    -- Construct a rule with dynamic dependencies using 'dynamicRule'
    mkRule modNm =
      dynamicRule (static Dict)
        (mkCommand (static Dict) (static computeDepsAction) (allRuleIDs, inFile))
        (mkCommand (static Dict) (static runPPAction) (inFile, outFile))
        [ FileDependency $ Location sameDirectory (modPath <.> "myPp") ]
        ( Location autogenDir (modPath <.> "hs" )
        NE.:| [ Location buildDir (unsafeCoerceSymbolicPath modPath <.> "myPpIface") ] )
      where
        modPath = moduleNameSymbolicPath modNm
        inFile  = getSymbolicPath (sameDirectory </> modPath <.> "myPp")
        outFile = getSymbolicPath (autogenDir    </> modPath <.> "hs")

    autogenDir = ... -- derived from pbci
    buildDir   = ... -- derived from pbci

    registerOne :: ModuleName -> RulesM (ModuleName, RuleId)
    registerOne modNm = do
      rId <- registerRule ("MyPP: " <> show modNm) (mkRule modNm)
      return (modNm, rId)

  -- Return a map from ModuleName to RuleId (used above via RecursiveDo).
  allRuleIDs <- Map.fromList <$> traverse registerOne inputModNms
  return ()
@

Note the usage of @RecursiveDo@ to allow indexing into the set of all registered
rules in order to declare the dynamic dependencies of the rules.

In this example we use tuples for the command arguments and @[ModuleName]@ for
the result of the dynamic dependency command; these have the required instances
needed for serialisation. If you use custom datatypes for these, you will need
to derive @Binary@, @Show@, @Eq@ to satisfy the API requirements (enforced by
the various calls to @static Dict@).
-}

{- $rulesDeps
Rules can declare various kinds of dependencies:

  - static dependencies: files or other rules that a rule statically depends on,
  - extra dynamic dependencies, using 'dynamicRule' smart constructor,
  - 'MonitorFilePath': additional files and directories to monitor.

Rules are considered __out-of-date__ precisely when any of the following
conditions apply:

  [O1] there has been a (relevant) change in the files and directories
       monitored by the rules,
  [O2] the environment passed to the computation of rules has changed.

If the rules are out-of-date, the build system is expected to re-run the
computation that computes all rules.

After this re-computation of the set of all rules, we match up new rules
with old rules, by 'RuleId'. A rule is then considered __stale__ if any of
following conditions apply:

  [N] the rule is new, or
  [S] the rule matches with an old rule, and either:

    [S1] a file dependency of the rule has been modified\/created\/deleted,
         or a (transitive) rule dependency of the rule is itself stale, or
    [S2] the rule is different from the old rule, e.g. the argument stored in
         the rule command has changed, or the pointer to the action to run the
         rule has changed. (This is determined using the @Eq Rule@ instance.)

A stale rule becomes no longer stale once we run its associated action. The
build system is responsible for re-running the actions associated with
each stale rule, in dependency order. This means the build system is expected
to behave as follows:

  1. Any time the rules are out-of-date, query the rules to obtain
     up-to-date rules.
  2. Re-run stale rules.

Cabal will execute all **demanded** rules in dependency order. A rule is
demanded if it satisfies one of the following conditions:

  1. It is a dependency of another demanded rule.
  2. The rule generates a Haskell file declared in the autogen-modules field.
     In this case, the rule **must** place the generated source file in the
     'autogenComponentModulesDir' appropriate for the component.
  3. (Since Cabal 3.18 only) The rule generates a non-Haskell source file, such
     as a C or JavaScript source. In this case (because there is no
     "autogen-c-sources" field), the following steps must be taken:
       a. Add the file to the 'c-sources' (or 'js-sources', etc) field of the
          package description in a per-component pre-configure hook, declaring it
          in the same 'autogenComponentModulesDir' directory (as if it was a @.hs@ file).
       b. Add a pre-build rule that generates the source file and puts it in
          this same 'autogenComponentModulesDir' directory.
     Note that any file declared in the 'includes'/'autogen-includes' fields
     must be present at **configure** time, so cannot be generated in a
     pre-build rule. In that case, either use a pre-configure hook or don't
     declare it under the 'includes' field (if possible).
  4. (Since Cabal 3.18 only) The rule generates an extra bundled library file,
     placed in the 'autogenComponentModulesDir' and with a filename matching
     one of the libraries named in the 'extra-bundled-libraries' field (ignoring
     file extension).
-}

{- $rulesAPI
Defining pre-build rules can be done in the following style:

> {-# LANGUAGE BlockArguments, StaticPointers #-}
> myPreBuildRules :: PreBuildComponentRules
> myPreBuildRules = rules (static ()) $ \ preBuildEnvironment -> do
>   let cmd1 = mkCommand (static Dict) $ static \ arg -> do { .. }
>       cmd2 = mkCommand (static Dict) $ static \ arg -> do { .. }
>   myData <- liftIO someIOAction
>   addRuleMonitors [ monitorDirectory "someSearchDir" ]
>   registerRule_ "rule_1_1" $ staticRule (cmd1 arg1) deps1 outs1
>   registerRule_ "rule_1_2" $ staticRule (cmd1 arg2) deps2 outs2
>   registerRule_ "rule_1_3" $ staticRule (cmd1 arg3) deps3 outs3
>   registerRule_ "rule_2_4" $ staticRule (cmd2 arg4) deps4 outs4

Here we use the 'rules', 'staticRule' and 'mkCommand' smart constructors,
rather than directly using the v'Rules', v'Rule' and v'Command' constructors,
which insulates us from internal changes to the t'Rules', t'Rule' and t'Command'
datatypes, respectively.

We use 'addRuleMonitors' to declare a monitored directory that the collection
of rules as a whole depends on. In this case, we declare that they depend on the
contents of the "searchDir" directory. This means that the rules will be
computed anew whenever the contents of this directory change. (This does not
mean all the rules will be re-run; only the out-of-date rules will be re-run.)
-}

{- Note [Not hiding SetupHooks constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We would like to hide as many datatype constructors from the API as possible
and provide smart constructors instead, so that hook authors don't end up
depending on internal implementation details that are subject to change.

However, doing so significantly degrades the Haddock documentation. So we
instead opt for exposing the constructor, but suggesting users use the
corresponding smart constructor instead.
-}

--------------------------------------------------------------------------------
-- API functions

-- | Register a rule. Returns an identifier for that rule.
registerRule
  :: ShortText -- ^ user-given rule name;
               -- these should be unique on a per-package level
  -> Rule      -- ^ the rule to register
  -> RulesM RuleId
registerRule :: ShortText -> Rule -> RulesM RuleId
registerRule ShortText
nm !Rule
newRule = ReaderT
  RulesEnv
  (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
  RuleId
-> RulesM RuleId
forall (m :: * -> *) a.
ReaderT
  RulesEnv (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m)) a
-> RulesT m a
RulesT (ReaderT
   RulesEnv
   (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
   RuleId
 -> RulesM RuleId)
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     RuleId
-> RulesM RuleId
forall a b. (a -> b) -> a -> b
$ do
  RulesEnv { rulesEnvNameSpace :: RulesEnv -> RulesNameSpace
rulesEnvNameSpace = RulesNameSpace
ns
           , rulesEnvVerbosity :: RulesEnv -> Verbosity
rulesEnvVerbosity = Verbosity
verbosity } <- ReaderT
  RulesEnv
  (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
  RulesEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
Reader.ask
  Map RuleId Rule
oldRules <- StateT
  (Map RuleId Rule) (WriterT [MonitorFilePath] IO) (Map RuleId Rule)
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     (Map RuleId Rule)
forall (m :: * -> *) a. Monad m => m a -> ReaderT RulesEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT
  (Map RuleId Rule) (WriterT [MonitorFilePath] IO) (Map RuleId Rule)
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
  let rId :: RuleId
rId = RuleId { ruleNameSpace :: RulesNameSpace
ruleNameSpace = RulesNameSpace
ns, ruleName :: ShortText
ruleName = ShortText
nm }
      (Maybe Rule
mbDup, Map RuleId Rule
newRules) = (RuleId -> Rule -> Rule -> Rule)
-> RuleId
-> Rule
-> Map RuleId Rule
-> (Maybe Rule, Map RuleId Rule)
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.insertLookupWithKey (\ RuleId
_ Rule
new Rule
_old -> Rule
new) RuleId
rId Rule
newRule Map RuleId Rule
oldRules
  Maybe Rule
-> (Rule
    -> ReaderT
         RulesEnv
         (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
         Any)
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Rule
mbDup ((Rule
  -> ReaderT
       RulesEnv
       (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
       Any)
 -> ReaderT
      RulesEnv
      (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
      ())
-> (Rule
    -> ReaderT
         RulesEnv
         (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
         Any)
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
forall a b. (a -> b) -> a -> b
$ \ Rule
oldRule ->
    IO Any
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     Any
forall a.
IO a
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Any
 -> ReaderT
      RulesEnv
      (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
      Any)
-> IO Any
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     Any
forall a b. (a -> b) -> a -> b
$ Verbosity -> CabalException -> IO Any
forall a1 a.
(HasCallStack, Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity
           (CabalException -> IO Any) -> CabalException -> IO Any
forall a b. (a -> b) -> a -> b
$ SetupHooksException -> CabalException
SetupHooksException
           (SetupHooksException -> CabalException)
-> SetupHooksException -> CabalException
forall a b. (a -> b) -> a -> b
$ RulesException -> SetupHooksException
RulesException
           (RulesException -> SetupHooksException)
-> RulesException -> SetupHooksException
forall a b. (a -> b) -> a -> b
$ RuleId -> Rule -> Rule -> RulesException
DuplicateRuleId RuleId
rId Rule
oldRule Rule
newRule
  StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO) ()
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT RulesEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO) ()
 -> ReaderT
      RulesEnv
      (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
      ())
-> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO) ()
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
forall a b. (a -> b) -> a -> b
$ Map RuleId Rule
-> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put Map RuleId Rule
newRules
  RuleId
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     RuleId
forall a.
a
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     a
forall (m :: * -> *) a. Monad m => a -> m a
return RuleId
rId

-- | Register a rule, discarding the produced 'RuleId'.
--
-- Using this function means that you don't expect any other rules to ever
-- depend on any outputs of this rule. Use 'registerRule' to retain the
-- 'RuleId' instead.
registerRule_
  :: ShortText -- ^ user-given rule name;
               -- these should be unique on a per-package level
  -> Rule      -- ^ the rule to register
  -> RulesT IO ()
registerRule_ :: ShortText -> Rule -> RulesT IO ()
registerRule_ ShortText
i Rule
r = RulesM RuleId -> RulesT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RulesM RuleId -> RulesT IO ()) -> RulesM RuleId -> RulesT IO ()
forall a b. (a -> b) -> a -> b
$ ShortText -> Rule -> RulesM RuleId
registerRule ShortText
i Rule
r

-- | Declare additional monitored objects for the collection of all rules.
--
-- When these monitored objects change, the rules are re-computed.
--
-- See also 'findAndMonitorDirFileGlob' which combines the search and the
-- monitoring.
addRuleMonitors :: Monad m => [MonitorFilePath] -> RulesT m ()
addRuleMonitors :: forall (m :: * -> *). Monad m => [MonitorFilePath] -> RulesT m ()
addRuleMonitors = ReaderT
  RulesEnv
  (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m))
  ()
-> RulesT m ()
forall (m :: * -> *) a.
ReaderT
  RulesEnv (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m)) a
-> RulesT m a
RulesT (ReaderT
   RulesEnv
   (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m))
   ()
 -> RulesT m ())
-> ([MonitorFilePath]
    -> ReaderT
         RulesEnv
         (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m))
         ())
-> [MonitorFilePath]
-> RulesT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m) ()
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m))
     ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT RulesEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m) ()
 -> ReaderT
      RulesEnv
      (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m))
      ())
-> ([MonitorFilePath]
    -> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m) ())
-> [MonitorFilePath]
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m))
     ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [MonitorFilePath] m ()
-> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m) ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map RuleId Rule) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT [MonitorFilePath] m ()
 -> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m) ())
-> ([MonitorFilePath] -> WriterT [MonitorFilePath] m ())
-> [MonitorFilePath]
-> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MonitorFilePath] -> WriterT [MonitorFilePath] m ()
forall w (m :: * -> *). (Monoid w, Monad m) => w -> WriterT w m ()
Writer.tell
{-# INLINEABLE addRuleMonitors #-}

-- | Retrieve all files matching the given 'Glob' in the specified search
-- directories.
--
-- See also the canned 'findAndMonitorSourceDirsFileExts' for the simple
-- case of monitoring a file extension in the source directories of a component.
findAndMonitorDirFileGlob
  :: MonadIO m
  => Maybe (SymbolicPath CWD (Dir Pkg))
  -> Verbosity
  -> [SymbolicPath Pkg (Dir dir)]
     -- ^ search directories
  -> Glob
     -- ^ pattern to match against
  -> RulesT m [Location]
findAndMonitorDirFileGlob :: forall (m :: * -> *) dir.
MonadIO m =>
Maybe (SymbolicPath CWD ('Dir Pkg))
-> Verbosity
-> [SymbolicPath Pkg ('Dir dir)]
-> Glob
-> RulesT m [Location]
findAndMonitorDirFileGlob Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir Verbosity
verb [SymbolicPath Pkg ('Dir dir)]
searchDirs Glob
glob = do
  [Location]
matchingFiles <- ([[Location]] -> [Location])
-> RulesT m [[Location]] -> RulesT m [Location]
forall a b. (a -> b) -> RulesT m a -> RulesT m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Location]] -> [Location]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (RulesT m [[Location]] -> RulesT m [Location])
-> RulesT m [[Location]] -> RulesT m [Location]
forall a b. (a -> b) -> a -> b
$ IO [[Location]] -> RulesT m [[Location]]
forall a. IO a -> RulesT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Location]] -> RulesT m [[Location]])
-> IO [[Location]] -> RulesT m [[Location]]
forall a b. (a -> b) -> a -> b
$ [SymbolicPath Pkg ('Dir dir)]
-> (SymbolicPath Pkg ('Dir dir) -> IO [Location])
-> IO [[Location]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [SymbolicPath Pkg ('Dir dir)]
searchDirs ((SymbolicPath Pkg ('Dir dir) -> IO [Location]) -> IO [[Location]])
-> (SymbolicPath Pkg ('Dir dir) -> IO [Location])
-> IO [[Location]]
forall a b. (a -> b) -> a -> b
$ \SymbolicPath Pkg ('Dir dir)
srcDir -> do
    let root :: FilePath
root = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir dir) -> FilePath
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> FilePath
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir dir)
srcDir
    [GlobResult FilePath]
matches <- Verbosity
-> Maybe CabalSpecVersion
-> FilePath
-> Glob
-> IO [GlobResult FilePath]
runDirFileGlob Verbosity
verb Maybe CabalSpecVersion
forall a. Maybe a
Nothing FilePath
root Glob
glob
    [Location] -> IO [Location]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
      [ SymbolicPath Pkg ('Dir dir) -> RelativePath dir 'File -> Location
forall baseDir.
SymbolicPath Pkg ('Dir baseDir)
-> RelativePath baseDir 'File -> Location
Location SymbolicPath Pkg ('Dir dir)
srcDir (FilePath -> RelativePath dir 'File
forall from (to :: FileOrDir).
HasCallStack =>
FilePath -> RelativePath from to
makeRelativePathEx FilePath
match)
      | FilePath
match <- [GlobResult FilePath] -> [FilePath]
forall a. [GlobResult a] -> [a]
globMatches [GlobResult FilePath]
matches
      ]
  [MonitorFilePath] -> RulesT m ()
forall (m :: * -> *). Monad m => [MonitorFilePath] -> RulesT m ()
addRuleMonitors [RootedGlob -> MonitorFilePath
monitorFileGlobExistence (RootedGlob -> MonitorFilePath) -> RootedGlob -> MonitorFilePath
forall a b. (a -> b) -> a -> b
$ FilePathRoot -> Glob -> RootedGlob
RootedGlob FilePathRoot
FilePathRelative Glob
glob]
  [Location] -> RulesT m [Location]
forall a. a -> RulesT m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Location]
matchingFiles
{-# INLINEABLE findAndMonitorDirFileGlob #-}

-- | Scans the component source directories for files with the given extensions,
-- and monitors the resulting file glob.
findAndMonitorSourceDirsFileExts
  :: MonadIO m
  => PreBuildComponentInputs
  -> NE.NonEmpty String -- ^ extensions (not including the @.@)
  -> RulesT m [Location]
findAndMonitorSourceDirsFileExts :: forall (m :: * -> *).
MonadIO m =>
PreBuildComponentInputs -> NonEmpty FilePath -> RulesT m [Location]
findAndMonitorSourceDirsFileExts
  PreBuildComponentInputs
    { LocalBuildInfo
localBuildInfo :: LocalBuildInfo
localBuildInfo :: PreBuildComponentInputs -> LocalBuildInfo
localBuildInfo
    , buildingWhat :: PreBuildComponentInputs -> BuildingWhat
buildingWhat = BuildingWhat
what
    , TargetInfo
targetInfo :: TargetInfo
targetInfo :: PreBuildComponentInputs -> TargetInfo
targetInfo
    } NonEmpty FilePath
exts =
  let
    comp :: Component
comp       = TargetInfo -> Component
targetComponent TargetInfo
targetInfo
    verbosity :: Verbosity
verbosity  = VerbosityHandles -> VerbosityFlags -> Verbosity
mkVerbosity VerbosityHandles
defaultVerbosityHandles (BuildingWhat -> VerbosityFlags
buildingWhatVerbosity BuildingWhat
what)
    mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir  = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
localBuildInfo
    searchDirs :: [SymbolicPath Pkg ('Dir Source)]
searchDirs = BuildInfo -> [SymbolicPath Pkg ('Dir Source)]
hsSourceDirs (BuildInfo -> [SymbolicPath Pkg ('Dir Source)])
-> BuildInfo -> [SymbolicPath Pkg ('Dir Source)]
forall a b. (a -> b) -> a -> b
$ Component -> BuildInfo
componentBuildInfo Component
comp
    fileGlob :: [GlobPiece]
fileGlob   = case NonEmpty FilePath
exts of
      FilePath
e NE.:| []  -> [GlobPiece
WildCard, FilePath -> GlobPiece
Literal (FilePath
"." FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
e)]
      FilePath
e NE.:| [FilePath]
es  -> [GlobPiece
WildCard, FilePath -> GlobPiece
Literal FilePath
".", [[GlobPiece]] -> GlobPiece
Union ((FilePath -> [GlobPiece]) -> [FilePath] -> [[GlobPiece]]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
ext -> [FilePath -> GlobPiece
Literal FilePath
ext]) (FilePath
e FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
es))]
    glob :: Glob
glob       = [GlobPiece] -> Glob
GlobDirRecursive [GlobPiece]
fileGlob
  in
    Maybe (SymbolicPath CWD ('Dir Pkg))
-> Verbosity
-> [SymbolicPath Pkg ('Dir Source)]
-> Glob
-> RulesT m [Location]
forall (m :: * -> *) dir.
MonadIO m =>
Maybe (SymbolicPath CWD ('Dir Pkg))
-> Verbosity
-> [SymbolicPath Pkg ('Dir dir)]
-> Glob
-> RulesT m [Location]
findAndMonitorDirFileGlob Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir Verbosity
verbosity [SymbolicPath Pkg ('Dir Source)]
searchDirs Glob
glob
{-# INLINEABLE findAndMonitorSourceDirsFileExts #-}