Internal.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module: Distribution.Simple.SetupHooks.Internal
--
-- Internal implementation module.
-- Users of @build-type: Hooks@ should import "Distribution.Simple.SetupHooks"
-- instead.
module Distribution.Simple.SetupHooks.Internal
  ( -- * The setup hooks datatype
    SetupHooks (..)
  , noSetupHooks

    -- * Configure hooks
  , ConfigureHooks (..)
  , noConfigureHooks

    -- ** Per-package configure hooks
  , PreConfPackageInputs (..)
  , PreConfPackageOutputs (..)
  , noPreConfPackageOutputs
  , PreConfPackageHook
  , PostConfPackageInputs (..)
  , PostConfPackageHook

    -- ** Per-component configure hooks
  , PreConfComponentInputs (..)
  , PreConfComponentOutputs (..)
  , noPreConfComponentOutputs
  , PreConfComponentHook
  , ComponentDiff (..)
  , emptyComponentDiff
  , buildInfoComponentDiff
  , LibraryDiff
  , ForeignLibDiff
  , ExecutableDiff
  , TestSuiteDiff
  , BenchmarkDiff
  , BuildInfoDiff

    -- * Build hooks
  , BuildHooks (..)
  , noBuildHooks
  , BuildingWhat (..)
  , buildingWhatVerbosity
  , buildingWhatDistPref

    -- ** Pre-build rules
  , PreBuildComponentInputs (..)
  , PreBuildComponentRules

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

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

    -- * Internals

    -- ** Per-component hook utilities
  , applyComponentDiffs
  , forComponents_

    -- ** Executing build rules
  , executeRules

    -- ** HookedBuildInfo compatibility code
  , hookedBuildInfoComponents
  , hookedBuildInfoComponentDiff_maybe
  )
where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Compat.Lens ((.~))
import Distribution.ModuleName
import Distribution.PackageDescription
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler (Compiler (..))
import Distribution.Simple.Errors
import Distribution.Simple.Flag
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program.Db
import Distribution.Simple.Setup
  ( HscolourFlags (..)
  , ReplFlags (..)
  )
import Distribution.Simple.Setup.Build (BuildFlags (..))
import Distribution.Simple.Setup.Config (ConfigFlags (..))
import Distribution.Simple.Setup.Copy (CopyFlags (..))
import Distribution.Simple.Setup.Haddock (HaddockFlags (..))
import Distribution.Simple.SetupHooks.Errors
import Distribution.Simple.SetupHooks.Rule
import qualified Distribution.Simple.SetupHooks.Rule as Rule
import Distribution.Simple.Utils
import Distribution.System (Platform (..))

import qualified Distribution.Types.BuildInfo.Lens as BI (buildInfo)
import Distribution.Types.LocalBuildConfig as LBC
import Distribution.Types.TargetInfo
import Distribution.Verbosity

import Data.Coerce (coerce)
import Data.Containers.ListUtils (nubOrd)
import qualified Data.Graph as Graph
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set

import System.Directory (doesFileExist)
import System.FilePath ((<.>), (</>))

--------------------------------------------------------------------------------
-- SetupHooks

-- | Hooks into the @cabal@ build phases.
--
-- Usage:
--
--  - In your @.cabal@ file, declare @build-type: Hooks@.
--  - Provide a @SetupHooks.hs@ module next to your @.cabal@ file;
--    it must export @setupHooks :: SetupHooks@.
--  - In your @.cabal@ file, include a @custom-setup@ stanza
--    which declares the dependencies of your @SetupHooks@ module.
data SetupHooks = SetupHooks
  { configureHooks :: ConfigureHooks
  -- ^ Hooks into the configure phase.
  , buildHooks :: BuildHooks
  -- ^ Hooks into the build phase.
  --
  -- These hooks are relevant to any build-like phase,
  -- such as repl or haddock.
  , installHooks :: InstallHooks
  -- ^ Hooks into the copy/install phase.
  }

-- | 'SetupHooks' can be combined monoidally. This is useful to combine
-- setup hooks defined by another package with your own package-specific
-- hooks.
--
-- __Warning__: this 'Semigroup' instance is not commutative.
instance Semigroup SetupHooks where
  SetupHooks
    { configureHooks = conf1
    , buildHooks = build1
    , installHooks = inst1
    }
    <> SetupHooks
      { configureHooks = conf2
      , buildHooks = build2
      , installHooks = inst2
      } =
      SetupHooks
        { configureHooks = conf1 <> conf2
        , buildHooks = build1 <> build2
        , installHooks = inst1 <> inst2
        }

instance Monoid SetupHooks where
  mempty = noSetupHooks

-- | Empty hooks.
noSetupHooks :: SetupHooks
noSetupHooks =
  SetupHooks
    { configureHooks = noConfigureHooks
    , buildHooks = noBuildHooks
    , installHooks = noInstallHooks
    }

--------------------------------------------------------------------------------
-- Configure hooks.

type PreConfPackageHook = PreConfPackageInputs -> IO PreConfPackageOutputs

-- | Inputs to the package-wide pre-configure step.
data PreConfPackageInputs = PreConfPackageInputs
  { configFlags :: ConfigFlags
  , localBuildConfig :: LocalBuildConfig
  -- ^ Warning: the 'ProgramDb' in the 'withPrograms' field
  -- will not contain any unconfigured programs.
  , compiler :: Compiler
  , platform :: Platform
  }
  deriving (Generic, Show)

-- | Outputs of the package-wide pre-configure step.
--
-- Prefer using 'noPreConfPackageOutputs' and overriding the fields
-- you care about, to avoid depending on implementation details
-- of this datatype.
data PreConfPackageOutputs = PreConfPackageOutputs
  { buildOptions :: BuildOptions
  , extraConfiguredProgs :: ConfiguredProgs
  }
  deriving (Generic, Show)

-- | Use this smart constructor to declare an empty set of changes
-- by the package-wide pre-configure hook, and override the fields you
-- care about.
--
-- Use this rather than v'PreConfPackageOutputs' to avoid relying on
-- internal implementation details of the latter.
noPreConfPackageOutputs :: PreConfPackageInputs -> PreConfPackageOutputs
noPreConfPackageOutputs (PreConfPackageInputs{localBuildConfig = lbc}) =
  PreConfPackageOutputs
    { buildOptions = LBC.withBuildOptions lbc
    , extraConfiguredProgs = Map.empty
    }

-- | Package-wide post-configure step.
--
-- Perform side effects. Last opportunity for any package-wide logic;
-- any subsequent hooks work per-component.
type PostConfPackageHook = PostConfPackageInputs -> IO ()

-- | Inputs to the package-wide post-configure step.
data PostConfPackageInputs = PostConfPackageInputs
  { localBuildConfig :: LocalBuildConfig
  , packageBuildDescr :: PackageBuildDescr
  }
  deriving (Generic, Show)

-- | Per-component pre-configure step.
--
-- For each component of the package, this hook can perform side effects,
-- and return a diff to the passed in component, e.g. to declare additional
-- autogenerated modules.
type PreConfComponentHook = PreConfComponentInputs -> IO PreConfComponentOutputs

-- | Inputs to the per-component pre-configure step.
data PreConfComponentInputs = PreConfComponentInputs
  { localBuildConfig :: LocalBuildConfig
  , packageBuildDescr :: PackageBuildDescr
  , component :: Component
  }
  deriving (Generic, Show)

-- | Outputs of the per-component pre-configure step.
--
-- Prefer using 'noPreComponentOutputs' and overriding the fields
-- you care about, to avoid depending on implementation details
-- of this datatype.
data PreConfComponentOutputs = PreConfComponentOutputs
  { componentDiff :: ComponentDiff
  }
  deriving (Generic, Show)

-- | Use this smart constructor to declare an empty set of changes
-- by a per-component pre-configure hook, and override the fields you
-- care about.
--
-- Use this rather than v'PreConfComponentOutputs' to avoid relying on
-- internal implementation details of the latter.
noPreConfComponentOutputs :: PreConfComponentInputs -> PreConfComponentOutputs
noPreConfComponentOutputs (PreConfComponentInputs{component = comp}) =
  PreConfComponentOutputs
    { componentDiff = emptyComponentDiff (componentName comp)
    }

-- | Configure-time hooks.
--
-- Order of execution:
--
--  - 'preConfPackageHook',
--  - configure the package,
--  - 'postConfPackageHook',
--  - 'preConfComponentHook',
--  - configure the components.
data ConfigureHooks = ConfigureHooks
  { preConfPackageHook :: Maybe PreConfPackageHook
  -- ^ Package-wide pre-configure hook. See 'PreConfPackageHook'.
  , postConfPackageHook :: Maybe PostConfPackageHook
  -- ^ Package-wide post-configure hook. See 'PostConfPackageHook'.
  , preConfComponentHook :: Maybe PreConfComponentHook
  -- ^ Per-component pre-configure hook. See 'PreConfComponentHook'.
  }

-- SetupHooks TODO: these configure hooks don't track any kind of
-- dependency information, so we won't know when the configuration is out
-- of date and should be re-done.
--
-- SetupHooks TODO: should we get rid of postConfPackageHook?
-- It is currently used to implement the Configure build-type using SetupHooks.

instance Semigroup ConfigureHooks where
  ConfigureHooks
    { preConfPackageHook = prePkg1
    , postConfPackageHook = postPkg1
    , preConfComponentHook = preComp1
    }
    <> ConfigureHooks
      { preConfPackageHook = prePkg2
      , postConfPackageHook = postPkg2
      , preConfComponentHook = preComp2
      } =
      ConfigureHooks
        { preConfPackageHook =
            coerce
              ((<>) @(Maybe PreConfPkgSemigroup))
              prePkg1
              prePkg2
        , postConfPackageHook =
            postPkg1 <> postPkg2
        , preConfComponentHook =
            coerce
              ((<>) @(Maybe PreConfComponentSemigroup))
              preComp1
              preComp2
        }

instance Monoid ConfigureHooks where
  mempty = noConfigureHooks

-- | Empty configure phase hooks.
noConfigureHooks :: ConfigureHooks
noConfigureHooks =
  ConfigureHooks
    { preConfPackageHook = Nothing
    , postConfPackageHook = Nothing
    , preConfComponentHook = Nothing
    }

-- | A newtype to hang off the @Semigroup PreConfPackageHook@ instance.
newtype PreConfPkgSemigroup = PreConfPkgSemigroup PreConfPackageHook

instance Semigroup PreConfPkgSemigroup where
  PreConfPkgSemigroup f1 <> PreConfPkgSemigroup f2 =
    PreConfPkgSemigroup $
      \inputs@( PreConfPackageInputs
                  { configFlags = cfg
                  , compiler = comp
                  , platform = plat
                  , localBuildConfig = lbc0
                  }
                ) ->
          do
            PreConfPackageOutputs
              { buildOptions = opts1
              , extraConfiguredProgs = progs1
              } <-
              f1 inputs
            PreConfPackageOutputs
              { buildOptions = opts2
              , extraConfiguredProgs = progs2
              } <-
              f2 $
                PreConfPackageInputs
                  { configFlags = cfg
                  , compiler = comp
                  , platform = plat
                  , localBuildConfig =
                      lbc0
                        { LBC.withPrograms =
                            updateConfiguredProgs (`Map.union` progs1) $
                              LBC.withPrograms lbc0
                        , LBC.withBuildOptions = opts1
                        }
                  }
            return $
              PreConfPackageOutputs
                { buildOptions = opts2
                , extraConfiguredProgs = progs1 <> progs2
                }

-- | A newtype to hang off the @Semigroup PreConfComponentHook@ instance.
newtype PreConfComponentSemigroup = PreConfComponentSemigroup PreConfComponentHook

instance Semigroup PreConfComponentSemigroup where
  PreConfComponentSemigroup f1 <> PreConfComponentSemigroup f2 =
    PreConfComponentSemigroup $ \inputs ->
      do
        PreConfComponentOutputs
          { componentDiff = diff1
          } <-
          f1 inputs
        PreConfComponentOutputs
          { componentDiff = diff2
          } <-
          f2 inputs
        return $
          PreConfComponentOutputs
            { componentDiff = diff1 <> diff2
            }

--------------------------------------------------------------------------------
-- Build setup hooks.

-- | What kind of build phase are we hooking into?
--
-- Is this a normal build, or is it perhaps for running an interactive
-- session or Haddock?
data BuildingWhat
  = -- | A normal build.
    BuildNormal BuildFlags
  | -- | Build steps for an interactive session.
    BuildRepl ReplFlags
  | -- | Build steps for generating documentation.
    BuildHaddock HaddockFlags
  | -- | Build steps for Hscolour.
    BuildHscolour HscolourFlags
  deriving (Generic, Show)

buildingWhatVerbosity :: BuildingWhat -> Verbosity
buildingWhatVerbosity = \case
  BuildNormal flags -> fromFlag $ buildVerbosity flags
  BuildRepl flags -> fromFlag $ replVerbosity flags
  BuildHaddock flags -> fromFlag $ haddockVerbosity flags
  BuildHscolour flags -> fromFlag $ hscolourVerbosity flags

buildingWhatDistPref :: BuildingWhat -> FilePath
buildingWhatDistPref = \case
  BuildNormal flags -> fromFlag $ buildDistPref flags
  BuildRepl flags -> fromFlag $ replDistPref flags
  BuildHaddock flags -> fromFlag $ haddockDistPref flags
  BuildHscolour flags -> fromFlag $ hscolourDistPref flags

data PreBuildComponentInputs = PreBuildComponentInputs
  { buildingWhat :: BuildingWhat
  -- ^ what kind of build phase are we hooking into?
  , localBuildInfo :: LocalBuildInfo
  -- ^ information about the package
  , targetInfo :: TargetInfo
  -- ^ information about an individual component
  }
  deriving (Generic, Show)

type PreBuildComponentRules = Rules PreBuildComponentInputs

data PostBuildComponentInputs = PostBuildComponentInputs
  { buildFlags :: BuildFlags
  , localBuildInfo :: LocalBuildInfo
  , targetInfo :: TargetInfo
  }
  deriving (Generic, Show)

type PostBuildComponentHook = PostBuildComponentInputs -> IO ()

-- | Build-time hooks.
data BuildHooks = BuildHooks
  { preBuildComponentRules :: Maybe PreBuildComponentRules
  -- ^ Per-component fine-grained pre-build rules.
  , postBuildComponentHook :: Maybe PostBuildComponentHook
  -- ^ Per-component post-build hook.
  }

-- SetupHooks TODO: the pre-build rules are a collection of rules
-- across all components. Each rule will get passed which component to
-- work with. This seems kind of wrong; we should have one graph of pre-build
-- rules for each component, e.g. instead of
--
-- [ Component -> BuildRule ]
--   it should be
-- Map ComponentName (Component -> BuildRule)
--   (or a proper dependent map, but let's not go there)
--
-- However, this is problematic in the presence of backpack, as
-- Backpack creates components on the fly through instantiation, which means
-- that a single component name can resolve to multiple components.

instance Semigroup BuildHooks where
  BuildHooks
    { preBuildComponentRules = rs1
    , postBuildComponentHook = post1
    }
    <> BuildHooks
      { preBuildComponentRules = rs2
      , postBuildComponentHook = post2
      } =
      BuildHooks
        { preBuildComponentRules = rs1 <> rs2
        , postBuildComponentHook = post1 <> post2
        }

instance Monoid BuildHooks where
  mempty = noBuildHooks

-- | Empty build hooks.
noBuildHooks :: BuildHooks
noBuildHooks =
  BuildHooks
    { preBuildComponentRules = Nothing
    , postBuildComponentHook = Nothing
    }

--------------------------------------------------------------------------------
-- Install setup hooks.

data InstallComponentInputs = InstallComponentInputs
  { copyFlags :: CopyFlags
  , localBuildInfo :: LocalBuildInfo
  , targetInfo :: TargetInfo
  }
  deriving (Generic, Show)

-- | A per-component install hook,
-- which can only perform side effects (e.g. copying files).
type InstallComponentHook = InstallComponentInputs -> IO ()

-- | Copy/install hooks.
data InstallHooks = InstallHooks
  { installComponentHook :: Maybe InstallComponentHook
  -- ^ Per-component install hook.
  }

instance Semigroup InstallHooks where
  InstallHooks
    { installComponentHook = inst1
    }
    <> InstallHooks
      { installComponentHook = inst2
      } =
      InstallHooks
        { installComponentHook = inst1 <> inst2
        }

instance Monoid InstallHooks where
  mempty = noInstallHooks

-- | Empty copy/install hooks.
noInstallHooks :: InstallHooks
noInstallHooks =
  InstallHooks
    { installComponentHook = Nothing
    }

--------------------------------------------------------------------------------
-- Per-component configure hook implementation details.

type LibraryDiff = Library
type ForeignLibDiff = ForeignLib
type ExecutableDiff = Executable
type TestSuiteDiff = TestSuite
type BenchmarkDiff = Benchmark
type BuildInfoDiff = BuildInfo

-- | A diff to a Cabal 'Component', that gets combined monoidally into
-- an existing 'Component'.
newtype ComponentDiff = ComponentDiff {componentDiff :: Component}
  deriving (Semigroup, Show)

emptyComponentDiff :: ComponentName -> ComponentDiff
emptyComponentDiff name = ComponentDiff $
  case name of
    CLibName{} -> CLib emptyLibrary
    CFLibName{} -> CFLib emptyForeignLib
    CExeName{} -> CExe emptyExecutable
    CTestName{} -> CTest emptyTestSuite
    CBenchName{} -> CBench emptyBenchmark

buildInfoComponentDiff :: ComponentName -> BuildInfo -> ComponentDiff
buildInfoComponentDiff name bi = ComponentDiff $
  BI.buildInfo .~ bi $
    case name of
      CLibName{} -> CLib emptyLibrary
      CFLibName{} -> CFLib emptyForeignLib
      CExeName{} -> CExe emptyExecutable
      CTestName{} -> CTest emptyTestSuite
      CBenchName{} -> CBench emptyBenchmark

applyLibraryDiff :: Verbosity -> Library -> LibraryDiff -> IO Library
applyLibraryDiff verbosity lib diff =
  case illegalLibraryDiffReasons lib diff of
    [] -> return $ lib <> diff
    (r : rs) ->
      dieWithException verbosity $
        SetupHooksException $
          CannotApplyComponentDiff $
            IllegalComponentDiff (CLib lib) (r NE.:| rs)

illegalLibraryDiffReasons :: Library -> LibraryDiff -> [IllegalComponentDiffReason]
illegalLibraryDiffReasons
  lib
  Library
    { libName = nm
    , libExposed = e
    , libVisibility = vis
    , libBuildInfo = bi
    } =
    [ CannotChangeName
    | not $ nm == libName emptyLibrary || nm == libName lib
    ]
      ++ [ CannotChangeComponentField "libExposed"
         | not $ e == libExposed emptyLibrary || e == libExposed lib
         ]
      ++ [ CannotChangeComponentField "libVisibility"
         | not $ vis == libVisibility emptyLibrary || vis == libVisibility lib
         ]
      ++ illegalBuildInfoDiffReasons (libBuildInfo lib) bi

applyForeignLibDiff :: Verbosity -> ForeignLib -> ForeignLibDiff -> IO ForeignLib
applyForeignLibDiff verbosity flib diff =
  case illegalForeignLibDiffReasons flib diff of
    [] -> return $ flib <> diff
    (r : rs) ->
      dieWithException verbosity $
        SetupHooksException $
          CannotApplyComponentDiff $
            IllegalComponentDiff (CFLib flib) (r NE.:| rs)

illegalForeignLibDiffReasons :: ForeignLib -> ForeignLibDiff -> [IllegalComponentDiffReason]
illegalForeignLibDiffReasons
  flib
  ForeignLib
    { foreignLibName = nm
    , foreignLibType = ty
    , foreignLibOptions = opts
    , foreignLibVersionInfo = vi
    , foreignLibVersionLinux = linux
    , foreignLibModDefFile = defs
    , foreignLibBuildInfo = bi
    } =
    [ CannotChangeName
    | not $ nm == foreignLibName emptyForeignLib || nm == foreignLibName flib
    ]
      ++ [ CannotChangeComponentField "foreignLibType"
         | not $ ty == foreignLibType emptyForeignLib || ty == foreignLibType flib
         ]
      ++ [ CannotChangeComponentField "foreignLibOptions"
         | not $ opts == foreignLibOptions emptyForeignLib || opts == foreignLibOptions flib
         ]
      ++ [ CannotChangeComponentField "foreignLibVersionInfo"
         | not $ vi == foreignLibVersionInfo emptyForeignLib || vi == foreignLibVersionInfo flib
         ]
      ++ [ CannotChangeComponentField "foreignLibVersionLinux"
         | not $ linux == foreignLibVersionLinux emptyForeignLib || linux == foreignLibVersionLinux flib
         ]
      ++ [ CannotChangeComponentField "foreignLibModDefFile"
         | not $ defs == foreignLibModDefFile emptyForeignLib || defs == foreignLibModDefFile flib
         ]
      ++ illegalBuildInfoDiffReasons (foreignLibBuildInfo flib) bi

applyExecutableDiff :: Verbosity -> Executable -> ExecutableDiff -> IO Executable
applyExecutableDiff verbosity exe diff =
  case illegalExecutableDiffReasons exe diff of
    [] -> return $ exe <> diff
    (r : rs) ->
      dieWithException verbosity $
        SetupHooksException $
          CannotApplyComponentDiff $
            IllegalComponentDiff (CExe exe) (r NE.:| rs)

illegalExecutableDiffReasons :: Executable -> ExecutableDiff -> [IllegalComponentDiffReason]
illegalExecutableDiffReasons
  exe
  Executable
    { exeName = nm
    , modulePath = path
    , exeScope = scope
    , buildInfo = bi
    } =
    [ CannotChangeName
    | not $ nm == exeName emptyExecutable || nm == exeName exe
    ]
      ++ [ CannotChangeComponentField "modulePath"
         | not $ path == modulePath emptyExecutable || path == modulePath exe
         ]
      ++ [ CannotChangeComponentField "exeScope"
         | not $ scope == exeScope emptyExecutable || scope == exeScope exe
         ]
      ++ illegalBuildInfoDiffReasons (buildInfo exe) bi

applyTestSuiteDiff :: Verbosity -> TestSuite -> TestSuiteDiff -> IO TestSuite
applyTestSuiteDiff verbosity test diff =
  case illegalTestSuiteDiffReasons test diff of
    [] -> return $ test <> diff
    (r : rs) ->
      dieWithException verbosity $
        SetupHooksException $
          CannotApplyComponentDiff $
            IllegalComponentDiff (CTest test) (r NE.:| rs)

illegalTestSuiteDiffReasons :: TestSuite -> TestSuiteDiff -> [IllegalComponentDiffReason]
illegalTestSuiteDiffReasons
  test
  TestSuite
    { testName = nm
    , testInterface = iface
    , testCodeGenerators = gens
    , testBuildInfo = bi
    } =
    [ CannotChangeName
    | not $ nm == testName emptyTestSuite || nm == testName test
    ]
      ++ [ CannotChangeComponentField "testInterface"
         | not $ iface == testInterface emptyTestSuite || iface == testInterface test
         ]
      ++ [ CannotChangeComponentField "testCodeGenerators"
         | not $ gens == testCodeGenerators emptyTestSuite || gens == testCodeGenerators test
         ]
      ++ illegalBuildInfoDiffReasons (testBuildInfo test) bi

applyBenchmarkDiff :: Verbosity -> Benchmark -> BenchmarkDiff -> IO Benchmark
applyBenchmarkDiff verbosity bench diff =
  case illegalBenchmarkDiffReasons bench diff of
    [] -> return $ bench <> diff
    (r : rs) ->
      dieWithException verbosity $
        SetupHooksException $
          CannotApplyComponentDiff $
            IllegalComponentDiff (CBench bench) (r NE.:| rs)

illegalBenchmarkDiffReasons :: Benchmark -> BenchmarkDiff -> [IllegalComponentDiffReason]
illegalBenchmarkDiffReasons
  bench
  Benchmark
    { benchmarkName = nm
    , benchmarkInterface = iface
    , benchmarkBuildInfo = bi
    } =
    [ CannotChangeName
    | not $ nm == benchmarkName emptyBenchmark || nm == benchmarkName bench
    ]
      ++ [ CannotChangeComponentField "benchmarkInterface"
         | not $ iface == benchmarkInterface emptyBenchmark || iface == benchmarkInterface bench
         ]
      ++ illegalBuildInfoDiffReasons (benchmarkBuildInfo bench) bi

illegalBuildInfoDiffReasons :: BuildInfo -> BuildInfoDiff -> [IllegalComponentDiffReason]
illegalBuildInfoDiffReasons
  bi
  BuildInfo
    { buildable = can_build
    , buildTools = build_tools
    , buildToolDepends = build_tools_depends
    , pkgconfigDepends = pkgconfig_depends
    , frameworks = fworks
    , targetBuildDepends = target_build_depends
    } =
    map CannotChangeBuildInfoField $
      [ "buildable"
      | not $ can_build == buildable bi || can_build == buildable emptyBuildInfo
      ]
        ++ [ "buildTools"
           | not $ build_tools == buildTools bi || build_tools == buildTools emptyBuildInfo
           ]
        ++ [ "buildToolsDepends"
           | not $ build_tools_depends == buildToolDepends bi || build_tools_depends == buildToolDepends emptyBuildInfo
           ]
        ++ [ "pkgconfigDepends"
           | not $ pkgconfig_depends == pkgconfigDepends bi || pkgconfig_depends == pkgconfigDepends emptyBuildInfo
           ]
        ++ [ "frameworks"
           | not $ fworks == frameworks bi || fworks == frameworks emptyBuildInfo
           ]
        ++ [ "targetBuildDepends"
           | not $ target_build_depends == targetBuildDepends bi || target_build_depends == targetBuildDepends emptyBuildInfo
           ]

-- | Traverse the components of a 'PackageDescription'.
--
-- The function must preserve the component type, i.e. map a 'CLib' to a 'CLib',
-- a 'CExe' to a 'CExe', etc.
traverseComponents
  :: Applicative m
  => (Component -> m Component)
  -> PackageDescription
  -> m PackageDescription
traverseComponents f pd =
  upd_pd
    <$> traverse f_lib (library pd)
    <*> traverse f_lib (subLibraries pd)
    <*> traverse f_flib (foreignLibs pd)
    <*> traverse f_exe (executables pd)
    <*> traverse f_test (testSuites pd)
    <*> traverse f_bench (benchmarks pd)
  where
    f_lib lib = \case { CLib lib' -> lib'; c -> mismatch (CLib lib) c } <$> f (CLib lib)
    f_flib flib = \case { CFLib flib' -> flib'; c -> mismatch (CFLib flib) c } <$> f (CFLib flib)
    f_exe exe = \case { CExe exe' -> exe'; c -> mismatch (CExe exe) c } <$> f (CExe exe)
    f_test test = \case { CTest test' -> test'; c -> mismatch (CTest test) c } <$> f (CTest test)
    f_bench bench = \case { CBench bench' -> bench'; c -> mismatch (CBench bench) c } <$> f (CBench bench)

    upd_pd lib sublibs flibs exes tests benchs =
      pd
        { library = lib
        , subLibraries = sublibs
        , foreignLibs = flibs
        , executables = exes
        , testSuites = tests
        , benchmarks = benchs
        }

    -- This is a panic, because we maintain this invariant elsewhere:
    -- see 'componentDiffError' in 'applyComponentDiff', which catches an
    -- invalid per-component configure hook.
    mismatch c1 c2 =
      error $
        "Mismatched component types: "
          ++ showComponentName (componentName c1)
          ++ " "
          ++ showComponentName (componentName c2)
          ++ "."
{-# INLINEABLE traverseComponents #-}

applyComponentDiffs
  :: Verbosity
  -> (Component -> IO (Maybe ComponentDiff))
  -> PackageDescription
  -> IO PackageDescription
applyComponentDiffs verbosity f = traverseComponents apply_diff
  where
    apply_diff :: Component -> IO Component
    apply_diff c = do
      mbDiff <- f c
      case mbDiff of
        Just diff -> applyComponentDiff verbosity c diff
        Nothing -> return c

forComponents_ :: PackageDescription -> (Component -> IO ()) -> IO ()
forComponents_ pd f = getConst $ traverseComponents (Const . f) pd

applyComponentDiff
  :: Verbosity
  -> Component
  -> ComponentDiff
  -> IO Component
applyComponentDiff verbosity comp (ComponentDiff diff)
  | CLib lib <- comp
  , CLib lib_diff <- diff =
      CLib <$> applyLibraryDiff verbosity lib lib_diff
  | CFLib flib <- comp
  , CFLib flib_diff <- diff =
      CFLib <$> applyForeignLibDiff verbosity flib flib_diff
  | CExe exe <- comp
  , CExe exe_diff <- diff =
      CExe <$> applyExecutableDiff verbosity exe exe_diff
  | CTest test <- comp
  , CTest test_diff <- diff =
      CTest <$> applyTestSuiteDiff verbosity test test_diff
  | CBench bench <- comp
  , CBench bench_diff <- diff =
      CBench <$> applyBenchmarkDiff verbosity bench bench_diff
  | otherwise =
      componentDiffError $ MismatchedComponentTypes comp diff
  where
    -- The per-component configure hook specified a diff of the wrong type,
    -- e.g. tried to apply an executable diff to a library.
    componentDiffError err =
      dieWithException verbosity $
        SetupHooksException $
          CannotApplyComponentDiff err

--------------------------------------------------------------------------------
-- Running pre-processors and code generators

-- | Run all preprocessors and code generators specified in
-- 'SetupHooks'.
--
-- This function should only be called internally within @Cabal@, as it is used
-- to implement the (legacy) Setup.hs interface. The build tool
-- (e.g. @cabal-install@ or @hls@) should instead go through the separate
-- hooks executable, which allows us to only rerun the out-of-date rules
-- (instead of running all of these rules at once).
executeRules
  :: Verbosity
  -> LocalBuildInfo
  -> TargetInfo
  -> Rules inputs
  -> inputs
  -> IO ()
executeRules verbosity lbi tgtInfo rulesFromInputs inputs = do
  -- Get all the rules, and create a build graph out of them.
  (actionFromId, getRulesAndMonitors) <- computeRules verbosity inputs rulesFromInputs
  allRules <- fst <$> getRulesAndMonitors
  let
    (ruleGraph, ruleFromVertex, vertexFromRuleId) =
      Graph.graphFromEdges
        [ (rule, rId, getDirectRuleDependencies rule)
        | (rId, rule) <- Map.toList allRules
        ]

    -- All the other rules that a given rule directly depends on, as determined
    -- by its 'dependencies'.
    getDirectRuleDependencies :: Rule -> [RuleId]
    getDirectRuleDependencies (Rule{dependencies = deps}) =
      nubOrd $ mapMaybe getDirectRuleDependencyMaybe deps

    getDirectRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId
    getDirectRuleDependencyMaybe (RuleDependency dep) = Just $ outputOfRule dep
    getDirectRuleDependencyMaybe (FileDependency{}) = Nothing

    -- Topologically sort the graph of rules.
    sccs = Graph.scc ruleGraph
    cycles = mapMaybe $ \(Graph.Node v0 subforest) ->
      case subforest of
        [] -> Nothing
        v : vs ->
          Just
            ( ruleFromVertex v0
            , NE.map (fmap ruleFromVertex) (v NE.:| vs)
            )

    -- Compute demanded rules.
    autogenModPaths =
      map (\m -> toFilePath m <.> "hs") $
        autogenModules $
          componentBuildInfo $
            targetComponent tgtInfo
    leafRule_maybe (rId, r) =
      if any ((r `ruleOutputsLocation`) . (compAutogenDir,)) autogenModPaths
        then vertexFromRuleId rId
        else Nothing
    leafRules = mapMaybe leafRule_maybe $ Map.toList allRules
    demandedRuleVerts = Set.fromList $ concatMap (Graph.reachable ruleGraph) leafRules
    nonDemandedRuleVerts = Set.fromList (Graph.vertices ruleGraph) Set.\\ demandedRuleVerts

  case cycles sccs of
    -- If there are cycles in the dependency structure, don't execute
    -- any rules at all; just throw an error right off the bat.
    r : rs ->
      let getRule ((ru, _, _), js) = (ru, fmap (fmap (\(rv, _, _) -> rv)) js)
       in errorOut $
            CyclicRuleDependencies $
              fmap getRule (r NE.:| rs)
    -- Otherwise, run all the demanded rules in dependency order (in one go).
    -- (Fine-grained running of rules should happen in cabal-install or HLS,
    -- not in the Cabal library.)
    [] -> do
      -- Emit a warning if there are non-demanded rules.
      unless (null nonDemandedRuleVerts) $
        warn verbosity $
          unlines $
            "The following rules are not demanded and will not be run:"
              : [ "  - " ++ show rId ++ ", generating " ++ showLocs (NE.toList $ results r)
                | v <- Set.toList nonDemandedRuleVerts
                , let (r, rId, _) = ruleFromVertex v
                ]
              ++ ["Perhaps some autogenerated modules were not declared at the configure stage?"]

      -- Run all the demanded rules, in dependency order.
      for_ sccs $ \(Graph.Node ruleVertex _) ->
        -- Don't run a rule unless it is demanded.
        unless (ruleVertex `Set.member` nonDemandedRuleVerts) $ do
          let (r@Rule{ruleActionId = actId, dependencies = deps, results = reslts}, rId, _) =
                ruleFromVertex ruleVertex
          case Map.lookup actId actionFromId of
            Nothing ->
              -- This is an internal error, because we don't expose the constructor
              -- of 'ActionId' through the SetupHooks interface, so it shouldn't
              -- be possible to conjure up invalid 'ActionId's (unless one is
              -- deliberately trying to cause trouble, e.g. by using unsafeCoerce).
              error $
                unlines
                  [ "Internal error when trying to execute rule " ++ show rId ++ ":"
                  , "there is no Action with " ++ show actId ++ "."
                  ]
            Just (Action{action = execRule}) -> do
              -- Check the dependencies the rule expects are indeed present.
              let resolvedDeps = map (resolveDependency allRules) deps
              missingRuleDeps <- filterM missingDep resolvedDeps
              case NE.nonEmpty missingRuleDeps of
                Just missingDeps ->
                  errorOut $ CantFindSourceForRuleDependencies r missingDeps
                -- Dependencies OK: run the associated action.
                Nothing -> do
                  execRule resolvedDeps reslts
                  -- Throw an error if running the action did not result in
                  -- the generation of outputs that we expected it to.
                  missingRuleResults <- filterM missingDep $ NE.toList reslts
                  for_ (NE.nonEmpty missingRuleResults) $ \missingResults ->
                    errorOut $ MissingRuleOutputs r missingResults
  where
    clbi = targetCLBI tgtInfo
    compAutogenDir = autogenComponentModulesDir lbi clbi
    errorOut e =
      dieWithException verbosity $
        SetupHooksException $
          RulesException e

resolveDependency :: Map RuleId Rule -> Rule.Dependency -> Location
resolveDependency allRules = \case
  FileDependency l -> l
  RuleDependency (RuleOutput{outputOfRule = depId, outputIndex = i}) ->
    case Map.lookup depId allRules of
      Nothing -> error $ "internal error: could not look up rule " ++ show depId
      Just (Rule{results = o}) ->
        NE.toList o !! i

-- SetupHooks TODO: either give proper error messages for these two potential
-- errors, or check this earlier, when constructing the graph?
-- (Does constructing the graph error if there are edges to non-existent
-- RuleIds?)

-- | Does the rule output the given location?
ruleOutputsLocation :: Rule -> Location -> Bool
ruleOutputsLocation (Rule{results = rs}) fp = any (== fp) rs

-- | Is the file we depend on missing?
missingDep :: Location -> IO Bool
missingDep (base, fp) = not <$> doesFileExist (base </> fp)

--------------------------------------------------------------------------------
-- Compatibility with HookedBuildInfo.
--
-- NB: assumes that the components in HookedBuildInfo are:
--  - an (optional) main library,
--  - executables.
--
-- No support for named sublibraries, foreign libraries, tests or benchmarks,
-- because the HookedBuildInfo datatype doesn't specify what type of component
-- each component name is (so we assume they are executables).

hookedBuildInfoComponents :: HookedBuildInfo -> Set ComponentName
hookedBuildInfoComponents (mb_mainlib, exes) =
  Set.fromList $
    (case mb_mainlib of Nothing -> id; Just{} -> (CLibName LMainLibName :))
      [CExeName exe_nm | (exe_nm, _) <- exes]

hookedBuildInfoComponentDiff_maybe :: HookedBuildInfo -> ComponentName -> Maybe (IO ComponentDiff)
hookedBuildInfoComponentDiff_maybe (mb_mainlib, exes) comp_nm =
  case comp_nm of
    CLibName lib_nm ->
      case lib_nm of
        LMainLibName -> return . ComponentDiff . CLib . buildInfoLibraryDiff <$> mb_mainlib
        LSubLibName{} -> Nothing
    CExeName exe_nm ->
      let mb_exe = lookup exe_nm exes
       in return . ComponentDiff . CExe . buildInfoExecutableDiff <$> mb_exe
    CFLibName{} -> Nothing
    CTestName{} -> Nothing
    CBenchName{} -> Nothing

buildInfoLibraryDiff :: BuildInfo -> LibraryDiff
buildInfoLibraryDiff bi = emptyLibrary{libBuildInfo = bi}

buildInfoExecutableDiff :: BuildInfo -> ExecutableDiff
buildInfoExecutableDiff bi = emptyExecutable{buildInfo = bi}

--------------------------------------------------------------------------------
-- Instances for serialisation

deriving newtype instance Binary ComponentDiff
deriving newtype instance Structured ComponentDiff
instance Binary BuildingWhat
instance Structured BuildingWhat

instance Binary PreConfPackageInputs
instance Structured PreConfPackageInputs
instance Binary PreConfPackageOutputs
instance Structured PreConfPackageOutputs

instance Binary PostConfPackageInputs
instance Structured PostConfPackageInputs

instance Binary PreConfComponentInputs
instance Structured PreConfComponentInputs
instance Binary PreConfComponentOutputs
instance Structured PreConfComponentOutputs

instance Binary PreBuildComponentInputs
instance Structured PreBuildComponentInputs

instance Binary PostBuildComponentInputs
instance Structured PostBuildComponentInputs

instance Binary InstallComponentInputs
instance Structured InstallComponentInputs

--------------------------------------------------------------------------------