{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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
  , buildingWhatWorkingDir
  , 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.PackageDescription
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler (Compiler (..))
import Distribution.Simple.Errors
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program.Db
import Distribution.Simple.Setup
  ( BuildingWhat (..)
  , buildingWhatDistPref
  , buildingWhatVerbosity
  , buildingWhatWorkingDir
  )
import Distribution.Simple.Setup.Build (BuildFlags (..))
import Distribution.Simple.Setup.Config (ConfigFlags (..))
import Distribution.Simple.Setup.Copy (CopyFlags (..))
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 Distribution.Utils.Path

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

import qualified Data.ByteString.Lazy as LBS
import Data.Coerce (coerce)
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)

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

-- | Hooks into the @cabal@ build phases.
--
-- Usage:
--
--  - In your @.cabal@ file, declare @build-type: Hooks@
--    (with a @cabal-version@ greater than or equal to @3.14@),
--  - In your @.cabal@ file, include a @custom-setup@ stanza
--    which declares the dependencies of your @SetupHooks@ module;
--    this will usually contain a dependency on the @Cabal-hooks@ package.
--  - Provide a @SetupHooks.hs@ module next to your @.cabal@ file;
--    it must export @setupHooks :: SetupHooks@.
data SetupHooks = SetupHooks
  { SetupHooks -> ConfigureHooks
configureHooks :: ConfigureHooks
  -- ^ Hooks into the configure phase.
  , SetupHooks -> BuildHooks
buildHooks :: BuildHooks
  -- ^ Hooks into the build phase.
  --
  -- These hooks are relevant to any build-like phase,
  -- such as repl or haddock.
  , SetupHooks -> InstallHooks
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 :: SetupHooks -> ConfigureHooks
configureHooks = ConfigureHooks
conf1
    , buildHooks :: SetupHooks -> BuildHooks
buildHooks = BuildHooks
build1
    , installHooks :: SetupHooks -> InstallHooks
installHooks = InstallHooks
inst1
    }
    <> :: SetupHooks -> SetupHooks -> SetupHooks
<> SetupHooks
      { configureHooks :: SetupHooks -> ConfigureHooks
configureHooks = ConfigureHooks
conf2
      , buildHooks :: SetupHooks -> BuildHooks
buildHooks = BuildHooks
build2
      , installHooks :: SetupHooks -> InstallHooks
installHooks = InstallHooks
inst2
      } =
      SetupHooks
        { configureHooks :: ConfigureHooks
configureHooks = ConfigureHooks
conf1 ConfigureHooks -> ConfigureHooks -> ConfigureHooks
forall a. Semigroup a => a -> a -> a
<> ConfigureHooks
conf2
        , buildHooks :: BuildHooks
buildHooks = BuildHooks
build1 BuildHooks -> BuildHooks -> BuildHooks
forall a. Semigroup a => a -> a -> a
<> BuildHooks
build2
        , installHooks :: InstallHooks
installHooks = InstallHooks
inst1 InstallHooks -> InstallHooks -> InstallHooks
forall a. Semigroup a => a -> a -> a
<> InstallHooks
inst2
        }

instance Monoid SetupHooks where
  mempty :: SetupHooks
mempty = SetupHooks
noSetupHooks

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

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

type PreConfPackageHook = PreConfPackageInputs -> IO PreConfPackageOutputs

-- | Inputs to the package-wide pre-configure step.
data PreConfPackageInputs = PreConfPackageInputs
  { PreConfPackageInputs -> ConfigFlags
configFlags :: ConfigFlags
  , PreConfPackageInputs -> LocalBuildConfig
localBuildConfig :: LocalBuildConfig
  -- ^ Warning: the 'ProgramDb' in the 'withPrograms' field
  -- will not contain any unconfigured programs.
  , PreConfPackageInputs -> Compiler
compiler :: Compiler
  , PreConfPackageInputs -> Platform
platform :: Platform
  }
  deriving ((forall x. PreConfPackageInputs -> Rep PreConfPackageInputs x)
-> (forall x. Rep PreConfPackageInputs x -> PreConfPackageInputs)
-> Generic PreConfPackageInputs
forall x. Rep PreConfPackageInputs x -> PreConfPackageInputs
forall x. PreConfPackageInputs -> Rep PreConfPackageInputs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PreConfPackageInputs -> Rep PreConfPackageInputs x
from :: forall x. PreConfPackageInputs -> Rep PreConfPackageInputs x
$cto :: forall x. Rep PreConfPackageInputs x -> PreConfPackageInputs
to :: forall x. Rep PreConfPackageInputs x -> PreConfPackageInputs
Generic, Int -> PreConfPackageInputs -> ShowS
[PreConfPackageInputs] -> ShowS
PreConfPackageInputs -> String
(Int -> PreConfPackageInputs -> ShowS)
-> (PreConfPackageInputs -> String)
-> ([PreConfPackageInputs] -> ShowS)
-> Show PreConfPackageInputs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PreConfPackageInputs -> ShowS
showsPrec :: Int -> PreConfPackageInputs -> ShowS
$cshow :: PreConfPackageInputs -> String
show :: PreConfPackageInputs -> String
$cshowList :: [PreConfPackageInputs] -> ShowS
showList :: [PreConfPackageInputs] -> ShowS
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
  { PreConfPackageOutputs -> BuildOptions
buildOptions :: BuildOptions
  , PreConfPackageOutputs -> ConfiguredProgs
extraConfiguredProgs :: ConfiguredProgs
  }
  deriving ((forall x. PreConfPackageOutputs -> Rep PreConfPackageOutputs x)
-> (forall x. Rep PreConfPackageOutputs x -> PreConfPackageOutputs)
-> Generic PreConfPackageOutputs
forall x. Rep PreConfPackageOutputs x -> PreConfPackageOutputs
forall x. PreConfPackageOutputs -> Rep PreConfPackageOutputs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PreConfPackageOutputs -> Rep PreConfPackageOutputs x
from :: forall x. PreConfPackageOutputs -> Rep PreConfPackageOutputs x
$cto :: forall x. Rep PreConfPackageOutputs x -> PreConfPackageOutputs
to :: forall x. Rep PreConfPackageOutputs x -> PreConfPackageOutputs
Generic, Int -> PreConfPackageOutputs -> ShowS
[PreConfPackageOutputs] -> ShowS
PreConfPackageOutputs -> String
(Int -> PreConfPackageOutputs -> ShowS)
-> (PreConfPackageOutputs -> String)
-> ([PreConfPackageOutputs] -> ShowS)
-> Show PreConfPackageOutputs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PreConfPackageOutputs -> ShowS
showsPrec :: Int -> PreConfPackageOutputs -> ShowS
$cshow :: PreConfPackageOutputs -> String
show :: PreConfPackageOutputs -> String
$cshowList :: [PreConfPackageOutputs] -> ShowS
showList :: [PreConfPackageOutputs] -> ShowS
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 -> PreConfPackageOutputs
noPreConfPackageOutputs (PreConfPackageInputs{localBuildConfig :: PreConfPackageInputs -> LocalBuildConfig
localBuildConfig = LocalBuildConfig
lbc}) =
  PreConfPackageOutputs
    { buildOptions :: BuildOptions
buildOptions = LocalBuildConfig -> BuildOptions
LBC.withBuildOptions LocalBuildConfig
lbc
    , extraConfiguredProgs :: ConfiguredProgs
extraConfiguredProgs = ConfiguredProgs
forall k a. Map k a
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
  { PostConfPackageInputs -> LocalBuildConfig
localBuildConfig :: LocalBuildConfig
  , PostConfPackageInputs -> PackageBuildDescr
packageBuildDescr :: PackageBuildDescr
  }
  deriving ((forall x. PostConfPackageInputs -> Rep PostConfPackageInputs x)
-> (forall x. Rep PostConfPackageInputs x -> PostConfPackageInputs)
-> Generic PostConfPackageInputs
forall x. Rep PostConfPackageInputs x -> PostConfPackageInputs
forall x. PostConfPackageInputs -> Rep PostConfPackageInputs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PostConfPackageInputs -> Rep PostConfPackageInputs x
from :: forall x. PostConfPackageInputs -> Rep PostConfPackageInputs x
$cto :: forall x. Rep PostConfPackageInputs x -> PostConfPackageInputs
to :: forall x. Rep PostConfPackageInputs x -> PostConfPackageInputs
Generic, Int -> PostConfPackageInputs -> ShowS
[PostConfPackageInputs] -> ShowS
PostConfPackageInputs -> String
(Int -> PostConfPackageInputs -> ShowS)
-> (PostConfPackageInputs -> String)
-> ([PostConfPackageInputs] -> ShowS)
-> Show PostConfPackageInputs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PostConfPackageInputs -> ShowS
showsPrec :: Int -> PostConfPackageInputs -> ShowS
$cshow :: PostConfPackageInputs -> String
show :: PostConfPackageInputs -> String
$cshowList :: [PostConfPackageInputs] -> ShowS
showList :: [PostConfPackageInputs] -> ShowS
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
  { PreConfComponentInputs -> LocalBuildConfig
localBuildConfig :: LocalBuildConfig
  , PreConfComponentInputs -> PackageBuildDescr
packageBuildDescr :: PackageBuildDescr
  , PreConfComponentInputs -> Component
component :: Component
  }
  deriving ((forall x. PreConfComponentInputs -> Rep PreConfComponentInputs x)
-> (forall x.
    Rep PreConfComponentInputs x -> PreConfComponentInputs)
-> Generic PreConfComponentInputs
forall x. Rep PreConfComponentInputs x -> PreConfComponentInputs
forall x. PreConfComponentInputs -> Rep PreConfComponentInputs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PreConfComponentInputs -> Rep PreConfComponentInputs x
from :: forall x. PreConfComponentInputs -> Rep PreConfComponentInputs x
$cto :: forall x. Rep PreConfComponentInputs x -> PreConfComponentInputs
to :: forall x. Rep PreConfComponentInputs x -> PreConfComponentInputs
Generic, Int -> PreConfComponentInputs -> ShowS
[PreConfComponentInputs] -> ShowS
PreConfComponentInputs -> String
(Int -> PreConfComponentInputs -> ShowS)
-> (PreConfComponentInputs -> String)
-> ([PreConfComponentInputs] -> ShowS)
-> Show PreConfComponentInputs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PreConfComponentInputs -> ShowS
showsPrec :: Int -> PreConfComponentInputs -> ShowS
$cshow :: PreConfComponentInputs -> String
show :: PreConfComponentInputs -> String
$cshowList :: [PreConfComponentInputs] -> ShowS
showList :: [PreConfComponentInputs] -> ShowS
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
  { PreConfComponentOutputs -> ComponentDiff
componentDiff :: ComponentDiff
  }
  deriving ((forall x.
 PreConfComponentOutputs -> Rep PreConfComponentOutputs x)
-> (forall x.
    Rep PreConfComponentOutputs x -> PreConfComponentOutputs)
-> Generic PreConfComponentOutputs
forall x. Rep PreConfComponentOutputs x -> PreConfComponentOutputs
forall x. PreConfComponentOutputs -> Rep PreConfComponentOutputs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PreConfComponentOutputs -> Rep PreConfComponentOutputs x
from :: forall x. PreConfComponentOutputs -> Rep PreConfComponentOutputs x
$cto :: forall x. Rep PreConfComponentOutputs x -> PreConfComponentOutputs
to :: forall x. Rep PreConfComponentOutputs x -> PreConfComponentOutputs
Generic, Int -> PreConfComponentOutputs -> ShowS
[PreConfComponentOutputs] -> ShowS
PreConfComponentOutputs -> String
(Int -> PreConfComponentOutputs -> ShowS)
-> (PreConfComponentOutputs -> String)
-> ([PreConfComponentOutputs] -> ShowS)
-> Show PreConfComponentOutputs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PreConfComponentOutputs -> ShowS
showsPrec :: Int -> PreConfComponentOutputs -> ShowS
$cshow :: PreConfComponentOutputs -> String
show :: PreConfComponentOutputs -> String
$cshowList :: [PreConfComponentOutputs] -> ShowS
showList :: [PreConfComponentOutputs] -> ShowS
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 -> PreConfComponentOutputs
noPreConfComponentOutputs (PreConfComponentInputs{component :: PreConfComponentInputs -> Component
component = Component
comp}) =
  PreConfComponentOutputs
    { componentDiff :: ComponentDiff
componentDiff = ComponentName -> ComponentDiff
emptyComponentDiff (Component -> ComponentName
componentName Component
comp)
    }

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

-- Note: 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.
-- This seems okay: it should only matter while developing the package, in which
-- case it seems acceptable to rely on the user re-configuring.

instance Semigroup ConfigureHooks where
  ConfigureHooks
    { preConfPackageHook :: ConfigureHooks -> Maybe PreConfPackageHook
preConfPackageHook = Maybe PreConfPackageHook
prePkg1
    , postConfPackageHook :: ConfigureHooks -> Maybe PostConfPackageHook
postConfPackageHook = Maybe PostConfPackageHook
postPkg1
    , preConfComponentHook :: ConfigureHooks -> Maybe PreConfComponentHook
preConfComponentHook = Maybe PreConfComponentHook
preComp1
    }
    <> :: ConfigureHooks -> ConfigureHooks -> ConfigureHooks
<> ConfigureHooks
      { preConfPackageHook :: ConfigureHooks -> Maybe PreConfPackageHook
preConfPackageHook = Maybe PreConfPackageHook
prePkg2
      , postConfPackageHook :: ConfigureHooks -> Maybe PostConfPackageHook
postConfPackageHook = Maybe PostConfPackageHook
postPkg2
      , preConfComponentHook :: ConfigureHooks -> Maybe PreConfComponentHook
preConfComponentHook = Maybe PreConfComponentHook
preComp2
      } =
      ConfigureHooks
        { preConfPackageHook :: Maybe PreConfPackageHook
preConfPackageHook =
            (Maybe PreConfPkgSemigroup
 -> Maybe PreConfPkgSemigroup -> Maybe PreConfPkgSemigroup)
-> Maybe PreConfPackageHook
-> Maybe PreConfPackageHook
-> Maybe PreConfPackageHook
forall a b. Coercible a b => a -> b
coerce
              (forall a. Semigroup a => a -> a -> a
(<>) @(Maybe PreConfPkgSemigroup))
              Maybe PreConfPackageHook
prePkg1
              Maybe PreConfPackageHook
prePkg2
        , postConfPackageHook :: Maybe PostConfPackageHook
postConfPackageHook =
            Maybe PostConfPackageHook
postPkg1 Maybe PostConfPackageHook
-> Maybe PostConfPackageHook -> Maybe PostConfPackageHook
forall a. Semigroup a => a -> a -> a
<> Maybe PostConfPackageHook
postPkg2
        , preConfComponentHook :: Maybe PreConfComponentHook
preConfComponentHook =
            (Maybe PreConfComponentSemigroup
 -> Maybe PreConfComponentSemigroup
 -> Maybe PreConfComponentSemigroup)
-> Maybe PreConfComponentHook
-> Maybe PreConfComponentHook
-> Maybe PreConfComponentHook
forall a b. Coercible a b => a -> b
coerce
              (forall a. Semigroup a => a -> a -> a
(<>) @(Maybe PreConfComponentSemigroup))
              Maybe PreConfComponentHook
preComp1
              Maybe PreConfComponentHook
preComp2
        }

instance Monoid ConfigureHooks where
  mempty :: ConfigureHooks
mempty = ConfigureHooks
noConfigureHooks

-- | Empty configure phase hooks.
noConfigureHooks :: ConfigureHooks
noConfigureHooks :: ConfigureHooks
noConfigureHooks =
  ConfigureHooks
    { preConfPackageHook :: Maybe PreConfPackageHook
preConfPackageHook = Maybe PreConfPackageHook
forall a. Maybe a
Nothing
    , postConfPackageHook :: Maybe PostConfPackageHook
postConfPackageHook = Maybe PostConfPackageHook
forall a. Maybe a
Nothing
    , preConfComponentHook :: Maybe PreConfComponentHook
preConfComponentHook = Maybe PreConfComponentHook
forall a. Maybe a
Nothing
    }

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

instance Semigroup PreConfPkgSemigroup where
  PreConfPkgSemigroup PreConfPackageHook
f1 <> :: PreConfPkgSemigroup -> PreConfPkgSemigroup -> PreConfPkgSemigroup
<> PreConfPkgSemigroup PreConfPackageHook
f2 =
    PreConfPackageHook -> PreConfPkgSemigroup
PreConfPkgSemigroup (PreConfPackageHook -> PreConfPkgSemigroup)
-> PreConfPackageHook -> PreConfPkgSemigroup
forall a b. (a -> b) -> a -> b
$
      \inputs :: PreConfPackageInputs
inputs@( PreConfPackageInputs
                  { configFlags :: PreConfPackageInputs -> ConfigFlags
configFlags = ConfigFlags
cfg
                  , compiler :: PreConfPackageInputs -> Compiler
compiler = Compiler
comp
                  , platform :: PreConfPackageInputs -> Platform
platform = Platform
plat
                  , localBuildConfig :: PreConfPackageInputs -> LocalBuildConfig
localBuildConfig = LocalBuildConfig
lbc0
                  }
                ) ->
          do
            PreConfPackageOutputs
              { buildOptions = opts1
              , extraConfiguredProgs = progs1
              } <-
              PreConfPackageHook
f1 PreConfPackageInputs
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 PreConfComponentHook
f1 <> :: PreConfComponentSemigroup
-> PreConfComponentSemigroup -> PreConfComponentSemigroup
<> PreConfComponentSemigroup PreConfComponentHook
f2 =
    PreConfComponentHook -> PreConfComponentSemigroup
PreConfComponentSemigroup (PreConfComponentHook -> PreConfComponentSemigroup)
-> PreConfComponentHook -> PreConfComponentSemigroup
forall a b. (a -> b) -> a -> b
$ \PreConfComponentInputs
inputs ->
      do
        PreConfComponentOutputs
          { componentDiff = diff1
          } <-
          PreConfComponentHook
f1 PreConfComponentInputs
inputs
        PreConfComponentOutputs
          { componentDiff = diff2
          } <-
          f2 inputs
        return $
          PreConfComponentOutputs
            { componentDiff = diff1 <> diff2
            }

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

data PreBuildComponentInputs = PreBuildComponentInputs
  { PreBuildComponentInputs -> BuildingWhat
buildingWhat :: BuildingWhat
  -- ^ what kind of build phase are we hooking into?
  , PreBuildComponentInputs -> LocalBuildInfo
localBuildInfo :: LocalBuildInfo
  -- ^ information about the package
  , PreBuildComponentInputs -> TargetInfo
targetInfo :: TargetInfo
  -- ^ information about an individual component
  }
  deriving ((forall x.
 PreBuildComponentInputs -> Rep PreBuildComponentInputs x)
-> (forall x.
    Rep PreBuildComponentInputs x -> PreBuildComponentInputs)
-> Generic PreBuildComponentInputs
forall x. Rep PreBuildComponentInputs x -> PreBuildComponentInputs
forall x. PreBuildComponentInputs -> Rep PreBuildComponentInputs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PreBuildComponentInputs -> Rep PreBuildComponentInputs x
from :: forall x. PreBuildComponentInputs -> Rep PreBuildComponentInputs x
$cto :: forall x. Rep PreBuildComponentInputs x -> PreBuildComponentInputs
to :: forall x. Rep PreBuildComponentInputs x -> PreBuildComponentInputs
Generic, Int -> PreBuildComponentInputs -> ShowS
[PreBuildComponentInputs] -> ShowS
PreBuildComponentInputs -> String
(Int -> PreBuildComponentInputs -> ShowS)
-> (PreBuildComponentInputs -> String)
-> ([PreBuildComponentInputs] -> ShowS)
-> Show PreBuildComponentInputs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PreBuildComponentInputs -> ShowS
showsPrec :: Int -> PreBuildComponentInputs -> ShowS
$cshow :: PreBuildComponentInputs -> String
show :: PreBuildComponentInputs -> String
$cshowList :: [PreBuildComponentInputs] -> ShowS
showList :: [PreBuildComponentInputs] -> ShowS
Show)

type PreBuildComponentRules = Rules PreBuildComponentInputs

data PostBuildComponentInputs = PostBuildComponentInputs
  { PostBuildComponentInputs -> BuildFlags
buildFlags :: BuildFlags
  , PostBuildComponentInputs -> LocalBuildInfo
localBuildInfo :: LocalBuildInfo
  , PostBuildComponentInputs -> TargetInfo
targetInfo :: TargetInfo
  }
  deriving ((forall x.
 PostBuildComponentInputs -> Rep PostBuildComponentInputs x)
-> (forall x.
    Rep PostBuildComponentInputs x -> PostBuildComponentInputs)
-> Generic PostBuildComponentInputs
forall x.
Rep PostBuildComponentInputs x -> PostBuildComponentInputs
forall x.
PostBuildComponentInputs -> Rep PostBuildComponentInputs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
PostBuildComponentInputs -> Rep PostBuildComponentInputs x
from :: forall x.
PostBuildComponentInputs -> Rep PostBuildComponentInputs x
$cto :: forall x.
Rep PostBuildComponentInputs x -> PostBuildComponentInputs
to :: forall x.
Rep PostBuildComponentInputs x -> PostBuildComponentInputs
Generic, Int -> PostBuildComponentInputs -> ShowS
[PostBuildComponentInputs] -> ShowS
PostBuildComponentInputs -> String
(Int -> PostBuildComponentInputs -> ShowS)
-> (PostBuildComponentInputs -> String)
-> ([PostBuildComponentInputs] -> ShowS)
-> Show PostBuildComponentInputs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PostBuildComponentInputs -> ShowS
showsPrec :: Int -> PostBuildComponentInputs -> ShowS
$cshow :: PostBuildComponentInputs -> String
show :: PostBuildComponentInputs -> String
$cshowList :: [PostBuildComponentInputs] -> ShowS
showList :: [PostBuildComponentInputs] -> ShowS
Show)

type PostBuildComponentHook = PostBuildComponentInputs -> IO ()

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

-- Note that the pre-build hook consists of a function which takes a component
-- as an argument (as part of the targetInfo field) and returns a collection of
-- pre-build rules.
--
-- One might wonder why it isn't instead a collection of pre-build rules, one
-- for each component. The reason is that Backpack creates components on-the-fly
-- through instantiation, which means e.g. that a single component name can
-- resolve to multiple components. This means we really need to pass in the
-- components to the function, as we don't know the full details (e.g. their
-- unit ids) ahead of time.

instance Semigroup BuildHooks where
  BuildHooks
    { preBuildComponentRules :: BuildHooks -> Maybe PreBuildComponentRules
preBuildComponentRules = Maybe PreBuildComponentRules
rs1
    , postBuildComponentHook :: BuildHooks -> Maybe PostBuildComponentHook
postBuildComponentHook = Maybe PostBuildComponentHook
post1
    }
    <> :: BuildHooks -> BuildHooks -> BuildHooks
<> BuildHooks
      { preBuildComponentRules :: BuildHooks -> Maybe PreBuildComponentRules
preBuildComponentRules = Maybe PreBuildComponentRules
rs2
      , postBuildComponentHook :: BuildHooks -> Maybe PostBuildComponentHook
postBuildComponentHook = Maybe PostBuildComponentHook
post2
      } =
      BuildHooks
        { preBuildComponentRules :: Maybe PreBuildComponentRules
preBuildComponentRules = Maybe PreBuildComponentRules
rs1 Maybe PreBuildComponentRules
-> Maybe PreBuildComponentRules -> Maybe PreBuildComponentRules
forall a. Semigroup a => a -> a -> a
<> Maybe PreBuildComponentRules
rs2
        , postBuildComponentHook :: Maybe PostBuildComponentHook
postBuildComponentHook = Maybe PostBuildComponentHook
post1 Maybe PostBuildComponentHook
-> Maybe PostBuildComponentHook -> Maybe PostBuildComponentHook
forall a. Semigroup a => a -> a -> a
<> Maybe PostBuildComponentHook
post2
        }

instance Monoid BuildHooks where
  mempty :: BuildHooks
mempty = BuildHooks
noBuildHooks

-- | Empty build hooks.
noBuildHooks :: BuildHooks
noBuildHooks :: BuildHooks
noBuildHooks =
  BuildHooks
    { preBuildComponentRules :: Maybe PreBuildComponentRules
preBuildComponentRules = Maybe PreBuildComponentRules
forall a. Maybe a
Nothing
    , postBuildComponentHook :: Maybe PostBuildComponentHook
postBuildComponentHook = Maybe PostBuildComponentHook
forall a. Maybe a
Nothing
    }

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

data InstallComponentInputs = InstallComponentInputs
  { InstallComponentInputs -> CopyFlags
copyFlags :: CopyFlags
  , InstallComponentInputs -> LocalBuildInfo
localBuildInfo :: LocalBuildInfo
  , InstallComponentInputs -> TargetInfo
targetInfo :: TargetInfo
  }
  deriving ((forall x. InstallComponentInputs -> Rep InstallComponentInputs x)
-> (forall x.
    Rep InstallComponentInputs x -> InstallComponentInputs)
-> Generic InstallComponentInputs
forall x. Rep InstallComponentInputs x -> InstallComponentInputs
forall x. InstallComponentInputs -> Rep InstallComponentInputs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. InstallComponentInputs -> Rep InstallComponentInputs x
from :: forall x. InstallComponentInputs -> Rep InstallComponentInputs x
$cto :: forall x. Rep InstallComponentInputs x -> InstallComponentInputs
to :: forall x. Rep InstallComponentInputs x -> InstallComponentInputs
Generic, Int -> InstallComponentInputs -> ShowS
[InstallComponentInputs] -> ShowS
InstallComponentInputs -> String
(Int -> InstallComponentInputs -> ShowS)
-> (InstallComponentInputs -> String)
-> ([InstallComponentInputs] -> ShowS)
-> Show InstallComponentInputs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InstallComponentInputs -> ShowS
showsPrec :: Int -> InstallComponentInputs -> ShowS
$cshow :: InstallComponentInputs -> String
show :: InstallComponentInputs -> String
$cshowList :: [InstallComponentInputs] -> ShowS
showList :: [InstallComponentInputs] -> ShowS
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
  { InstallHooks -> Maybe InstallComponentHook
installComponentHook :: Maybe InstallComponentHook
  -- ^ Per-component install hook.
  }

instance Semigroup InstallHooks where
  InstallHooks
    { installComponentHook :: InstallHooks -> Maybe InstallComponentHook
installComponentHook = Maybe InstallComponentHook
inst1
    }
    <> :: InstallHooks -> InstallHooks -> InstallHooks
<> InstallHooks
      { installComponentHook :: InstallHooks -> Maybe InstallComponentHook
installComponentHook = Maybe InstallComponentHook
inst2
      } =
      InstallHooks
        { installComponentHook :: Maybe InstallComponentHook
installComponentHook = Maybe InstallComponentHook
inst1 Maybe InstallComponentHook
-> Maybe InstallComponentHook -> Maybe InstallComponentHook
forall a. Semigroup a => a -> a -> a
<> Maybe InstallComponentHook
inst2
        }

instance Monoid InstallHooks where
  mempty :: InstallHooks
mempty = InstallHooks
noInstallHooks

-- | Empty copy/install hooks.
noInstallHooks :: InstallHooks
noInstallHooks :: InstallHooks
noInstallHooks =
  InstallHooks
    { installComponentHook :: Maybe InstallComponentHook
installComponentHook = Maybe InstallComponentHook
forall a. Maybe a
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
componentDiff :: Component}
  deriving (NonEmpty ComponentDiff -> ComponentDiff
ComponentDiff -> ComponentDiff -> ComponentDiff
(ComponentDiff -> ComponentDiff -> ComponentDiff)
-> (NonEmpty ComponentDiff -> ComponentDiff)
-> (forall b. Integral b => b -> ComponentDiff -> ComponentDiff)
-> Semigroup ComponentDiff
forall b. Integral b => b -> ComponentDiff -> ComponentDiff
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: ComponentDiff -> ComponentDiff -> ComponentDiff
<> :: ComponentDiff -> ComponentDiff -> ComponentDiff
$csconcat :: NonEmpty ComponentDiff -> ComponentDiff
sconcat :: NonEmpty ComponentDiff -> ComponentDiff
$cstimes :: forall b. Integral b => b -> ComponentDiff -> ComponentDiff
stimes :: forall b. Integral b => b -> ComponentDiff -> ComponentDiff
Semigroup, Int -> ComponentDiff -> ShowS
[ComponentDiff] -> ShowS
ComponentDiff -> String
(Int -> ComponentDiff -> ShowS)
-> (ComponentDiff -> String)
-> ([ComponentDiff] -> ShowS)
-> Show ComponentDiff
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ComponentDiff -> ShowS
showsPrec :: Int -> ComponentDiff -> ShowS
$cshow :: ComponentDiff -> String
show :: ComponentDiff -> String
$cshowList :: [ComponentDiff] -> ShowS
showList :: [ComponentDiff] -> ShowS
Show)

emptyComponentDiff :: ComponentName -> ComponentDiff
emptyComponentDiff :: ComponentName -> ComponentDiff
emptyComponentDiff ComponentName
name = Component -> ComponentDiff
ComponentDiff (Component -> ComponentDiff) -> Component -> ComponentDiff
forall a b. (a -> b) -> a -> b
$
  case ComponentName
name of
    CLibName{} -> Library -> Component
CLib Library
emptyLibrary
    CFLibName{} -> ForeignLib -> Component
CFLib ForeignLib
emptyForeignLib
    CExeName{} -> Executable -> Component
CExe Executable
emptyExecutable
    CTestName{} -> TestSuite -> Component
CTest TestSuite
emptyTestSuite
    CBenchName{} -> Benchmark -> Component
CBench Benchmark
emptyBenchmark

buildInfoComponentDiff :: ComponentName -> BuildInfo -> ComponentDiff
buildInfoComponentDiff :: ComponentName -> BuildInfo -> ComponentDiff
buildInfoComponentDiff ComponentName
name BuildInfo
bi = Component -> ComponentDiff
ComponentDiff (Component -> ComponentDiff) -> Component -> ComponentDiff
forall a b. (a -> b) -> a -> b
$
  LensLike Identity Component Component BuildInfo BuildInfo
forall a. HasBuildInfo a => Lens' a BuildInfo
Lens' Component BuildInfo
BI.buildInfo LensLike Identity Component Component BuildInfo BuildInfo
-> BuildInfo -> Component -> Component
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BuildInfo
bi (Component -> Component) -> Component -> Component
forall a b. (a -> b) -> a -> b
$
    case ComponentName
name of
      CLibName{} -> Library -> Component
CLib Library
emptyLibrary
      CFLibName{} -> ForeignLib -> Component
CFLib ForeignLib
emptyForeignLib
      CExeName{} -> Executable -> Component
CExe Executable
emptyExecutable
      CTestName{} -> TestSuite -> Component
CTest TestSuite
emptyTestSuite
      CBenchName{} -> Benchmark -> Component
CBench Benchmark
emptyBenchmark

applyLibraryDiff :: Verbosity -> Library -> LibraryDiff -> IO Library
applyLibraryDiff :: Verbosity -> Library -> Library -> IO Library
applyLibraryDiff Verbosity
verbosity Library
lib Library
diff =
  case Library -> Library -> [IllegalComponentDiffReason]
illegalLibraryDiffReasons Library
lib Library
diff of
    [] -> Library -> IO Library
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Library -> IO Library) -> Library -> IO Library
forall a b. (a -> b) -> a -> b
$ Library
lib Library -> Library -> Library
forall a. Semigroup a => a -> a -> a
<> Library
diff
    (IllegalComponentDiffReason
r : [IllegalComponentDiffReason]
rs) ->
      Verbosity -> CabalException -> IO Library
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO Library) -> CabalException -> IO Library
forall a b. (a -> b) -> a -> b
$
        SetupHooksException -> CabalException
SetupHooksException (SetupHooksException -> CabalException)
-> SetupHooksException -> CabalException
forall a b. (a -> b) -> a -> b
$
          CannotApplyComponentDiffReason -> SetupHooksException
CannotApplyComponentDiff (CannotApplyComponentDiffReason -> SetupHooksException)
-> CannotApplyComponentDiffReason -> SetupHooksException
forall a b. (a -> b) -> a -> b
$
            Component
-> NonEmpty IllegalComponentDiffReason
-> CannotApplyComponentDiffReason
IllegalComponentDiff (Library -> Component
CLib Library
lib) (IllegalComponentDiffReason
r IllegalComponentDiffReason
-> [IllegalComponentDiffReason]
-> NonEmpty IllegalComponentDiffReason
forall a. a -> [a] -> NonEmpty a
NE.:| [IllegalComponentDiffReason]
rs)

illegalLibraryDiffReasons :: Library -> LibraryDiff -> [IllegalComponentDiffReason]
illegalLibraryDiffReasons :: Library -> Library -> [IllegalComponentDiffReason]
illegalLibraryDiffReasons
  Library
lib
  Library
    { libName :: Library -> LibraryName
libName = LibraryName
nm
    , libExposed :: Library -> Bool
libExposed = Bool
e
    , libVisibility :: Library -> LibraryVisibility
libVisibility = LibraryVisibility
vis
    , libBuildInfo :: Library -> BuildInfo
libBuildInfo = BuildInfo
bi
    } =
    [ IllegalComponentDiffReason
CannotChangeName
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LibraryName
nm LibraryName -> LibraryName -> Bool
forall a. Eq a => a -> a -> Bool
== Library -> LibraryName
libName Library
emptyLibrary Bool -> Bool -> Bool
|| LibraryName
nm LibraryName -> LibraryName -> Bool
forall a. Eq a => a -> a -> Bool
== Library -> LibraryName
libName Library
lib
    ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ [ String -> IllegalComponentDiffReason
CannotChangeComponentField String
"libExposed"
         | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
e Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Library -> Bool
libExposed Library
emptyLibrary Bool -> Bool -> Bool
|| Bool
e Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Library -> Bool
libExposed Library
lib
         ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ [ String -> IllegalComponentDiffReason
CannotChangeComponentField String
"libVisibility"
         | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ LibraryVisibility
vis LibraryVisibility -> LibraryVisibility -> Bool
forall a. Eq a => a -> a -> Bool
== Library -> LibraryVisibility
libVisibility Library
emptyLibrary Bool -> Bool -> Bool
|| LibraryVisibility
vis LibraryVisibility -> LibraryVisibility -> Bool
forall a. Eq a => a -> a -> Bool
== Library -> LibraryVisibility
libVisibility Library
lib
         ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> BuildInfo -> [IllegalComponentDiffReason]
illegalBuildInfoDiffReasons (Library -> BuildInfo
libBuildInfo Library
lib) BuildInfo
bi

applyForeignLibDiff :: Verbosity -> ForeignLib -> ForeignLibDiff -> IO ForeignLib
applyForeignLibDiff :: Verbosity -> ForeignLib -> ForeignLib -> IO ForeignLib
applyForeignLibDiff Verbosity
verbosity ForeignLib
flib ForeignLib
diff =
  case ForeignLib -> ForeignLib -> [IllegalComponentDiffReason]
illegalForeignLibDiffReasons ForeignLib
flib ForeignLib
diff of
    [] -> ForeignLib -> IO ForeignLib
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignLib -> IO ForeignLib) -> ForeignLib -> IO ForeignLib
forall a b. (a -> b) -> a -> b
$ ForeignLib
flib ForeignLib -> ForeignLib -> ForeignLib
forall a. Semigroup a => a -> a -> a
<> ForeignLib
diff
    (IllegalComponentDiffReason
r : [IllegalComponentDiffReason]
rs) ->
      Verbosity -> CabalException -> IO ForeignLib
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ForeignLib)
-> CabalException -> IO ForeignLib
forall a b. (a -> b) -> a -> b
$
        SetupHooksException -> CabalException
SetupHooksException (SetupHooksException -> CabalException)
-> SetupHooksException -> CabalException
forall a b. (a -> b) -> a -> b
$
          CannotApplyComponentDiffReason -> SetupHooksException
CannotApplyComponentDiff (CannotApplyComponentDiffReason -> SetupHooksException)
-> CannotApplyComponentDiffReason -> SetupHooksException
forall a b. (a -> b) -> a -> b
$
            Component
-> NonEmpty IllegalComponentDiffReason
-> CannotApplyComponentDiffReason
IllegalComponentDiff (ForeignLib -> Component
CFLib ForeignLib
flib) (IllegalComponentDiffReason
r IllegalComponentDiffReason
-> [IllegalComponentDiffReason]
-> NonEmpty IllegalComponentDiffReason
forall a. a -> [a] -> NonEmpty a
NE.:| [IllegalComponentDiffReason]
rs)

illegalForeignLibDiffReasons :: ForeignLib -> ForeignLibDiff -> [IllegalComponentDiffReason]
illegalForeignLibDiffReasons :: ForeignLib -> ForeignLib -> [IllegalComponentDiffReason]
illegalForeignLibDiffReasons
  ForeignLib
flib
  ForeignLib
    { foreignLibName :: ForeignLib -> UnqualComponentName
foreignLibName = UnqualComponentName
nm
    , foreignLibType :: ForeignLib -> ForeignLibType
foreignLibType = ForeignLibType
ty
    , foreignLibOptions :: ForeignLib -> [ForeignLibOption]
foreignLibOptions = [ForeignLibOption]
opts
    , foreignLibVersionInfo :: ForeignLib -> Maybe LibVersionInfo
foreignLibVersionInfo = Maybe LibVersionInfo
vi
    , foreignLibVersionLinux :: ForeignLib -> Maybe Version
foreignLibVersionLinux = Maybe Version
linux
    , foreignLibModDefFile :: ForeignLib -> [RelativePath Source 'File]
foreignLibModDefFile = [RelativePath Source 'File]
defs
    , foreignLibBuildInfo :: ForeignLib -> BuildInfo
foreignLibBuildInfo = BuildInfo
bi
    } =
    [ IllegalComponentDiffReason
CannotChangeName
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UnqualComponentName
nm UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
emptyForeignLib Bool -> Bool -> Bool
|| UnqualComponentName
nm UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
flib
    ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ [ String -> IllegalComponentDiffReason
CannotChangeComponentField String
"foreignLibType"
         | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ForeignLibType
ty ForeignLibType -> ForeignLibType -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignLib -> ForeignLibType
foreignLibType ForeignLib
emptyForeignLib Bool -> Bool -> Bool
|| ForeignLibType
ty ForeignLibType -> ForeignLibType -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignLib -> ForeignLibType
foreignLibType ForeignLib
flib
         ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ [ String -> IllegalComponentDiffReason
CannotChangeComponentField String
"foreignLibOptions"
         | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ForeignLibOption]
opts [ForeignLibOption] -> [ForeignLibOption] -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignLib -> [ForeignLibOption]
foreignLibOptions ForeignLib
emptyForeignLib Bool -> Bool -> Bool
|| [ForeignLibOption]
opts [ForeignLibOption] -> [ForeignLibOption] -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignLib -> [ForeignLibOption]
foreignLibOptions ForeignLib
flib
         ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ [ String -> IllegalComponentDiffReason
CannotChangeComponentField String
"foreignLibVersionInfo"
         | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe LibVersionInfo
vi Maybe LibVersionInfo -> Maybe LibVersionInfo -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignLib -> Maybe LibVersionInfo
foreignLibVersionInfo ForeignLib
emptyForeignLib Bool -> Bool -> Bool
|| Maybe LibVersionInfo
vi Maybe LibVersionInfo -> Maybe LibVersionInfo -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignLib -> Maybe LibVersionInfo
foreignLibVersionInfo ForeignLib
flib
         ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ [ String -> IllegalComponentDiffReason
CannotChangeComponentField String
"foreignLibVersionLinux"
         | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe Version
linux Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignLib -> Maybe Version
foreignLibVersionLinux ForeignLib
emptyForeignLib Bool -> Bool -> Bool
|| Maybe Version
linux Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignLib -> Maybe Version
foreignLibVersionLinux ForeignLib
flib
         ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ [ String -> IllegalComponentDiffReason
CannotChangeComponentField String
"foreignLibModDefFile"
         | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [RelativePath Source 'File]
defs [RelativePath Source 'File] -> [RelativePath Source 'File] -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignLib -> [RelativePath Source 'File]
foreignLibModDefFile ForeignLib
emptyForeignLib Bool -> Bool -> Bool
|| [RelativePath Source 'File]
defs [RelativePath Source 'File] -> [RelativePath Source 'File] -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignLib -> [RelativePath Source 'File]
foreignLibModDefFile ForeignLib
flib
         ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> BuildInfo -> [IllegalComponentDiffReason]
illegalBuildInfoDiffReasons (ForeignLib -> BuildInfo
foreignLibBuildInfo ForeignLib
flib) BuildInfo
bi

applyExecutableDiff :: Verbosity -> Executable -> ExecutableDiff -> IO Executable
applyExecutableDiff :: Verbosity -> Executable -> Executable -> IO Executable
applyExecutableDiff Verbosity
verbosity Executable
exe Executable
diff =
  case Executable -> Executable -> [IllegalComponentDiffReason]
illegalExecutableDiffReasons Executable
exe Executable
diff of
    [] -> Executable -> IO Executable
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Executable -> IO Executable) -> Executable -> IO Executable
forall a b. (a -> b) -> a -> b
$ Executable
exe Executable -> Executable -> Executable
forall a. Semigroup a => a -> a -> a
<> Executable
diff
    (IllegalComponentDiffReason
r : [IllegalComponentDiffReason]
rs) ->
      Verbosity -> CabalException -> IO Executable
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO Executable)
-> CabalException -> IO Executable
forall a b. (a -> b) -> a -> b
$
        SetupHooksException -> CabalException
SetupHooksException (SetupHooksException -> CabalException)
-> SetupHooksException -> CabalException
forall a b. (a -> b) -> a -> b
$
          CannotApplyComponentDiffReason -> SetupHooksException
CannotApplyComponentDiff (CannotApplyComponentDiffReason -> SetupHooksException)
-> CannotApplyComponentDiffReason -> SetupHooksException
forall a b. (a -> b) -> a -> b
$
            Component
-> NonEmpty IllegalComponentDiffReason
-> CannotApplyComponentDiffReason
IllegalComponentDiff (Executable -> Component
CExe Executable
exe) (IllegalComponentDiffReason
r IllegalComponentDiffReason
-> [IllegalComponentDiffReason]
-> NonEmpty IllegalComponentDiffReason
forall a. a -> [a] -> NonEmpty a
NE.:| [IllegalComponentDiffReason]
rs)

illegalExecutableDiffReasons :: Executable -> ExecutableDiff -> [IllegalComponentDiffReason]
illegalExecutableDiffReasons :: Executable -> Executable -> [IllegalComponentDiffReason]
illegalExecutableDiffReasons
  Executable
exe
  Executable
    { exeName :: Executable -> UnqualComponentName
exeName = UnqualComponentName
nm
    , modulePath :: Executable -> RelativePath Source 'File
modulePath = RelativePath Source 'File
path
    , exeScope :: Executable -> ExecutableScope
exeScope = ExecutableScope
scope
    , buildInfo :: Executable -> BuildInfo
buildInfo = BuildInfo
bi
    } =
    [ IllegalComponentDiffReason
CannotChangeName
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UnqualComponentName
nm UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== Executable -> UnqualComponentName
exeName Executable
emptyExecutable Bool -> Bool -> Bool
|| UnqualComponentName
nm UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== Executable -> UnqualComponentName
exeName Executable
exe
    ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ [ String -> IllegalComponentDiffReason
CannotChangeComponentField String
"modulePath"
         | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RelativePath Source 'File
path RelativePath Source 'File -> RelativePath Source 'File -> Bool
forall a. Eq a => a -> a -> Bool
== Executable -> RelativePath Source 'File
modulePath Executable
emptyExecutable Bool -> Bool -> Bool
|| RelativePath Source 'File
path RelativePath Source 'File -> RelativePath Source 'File -> Bool
forall a. Eq a => a -> a -> Bool
== Executable -> RelativePath Source 'File
modulePath Executable
exe
         ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ [ String -> IllegalComponentDiffReason
CannotChangeComponentField String
"exeScope"
         | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ExecutableScope
scope ExecutableScope -> ExecutableScope -> Bool
forall a. Eq a => a -> a -> Bool
== Executable -> ExecutableScope
exeScope Executable
emptyExecutable Bool -> Bool -> Bool
|| ExecutableScope
scope ExecutableScope -> ExecutableScope -> Bool
forall a. Eq a => a -> a -> Bool
== Executable -> ExecutableScope
exeScope Executable
exe
         ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> BuildInfo -> [IllegalComponentDiffReason]
illegalBuildInfoDiffReasons (Executable -> BuildInfo
buildInfo Executable
exe) BuildInfo
bi

applyTestSuiteDiff :: Verbosity -> TestSuite -> TestSuiteDiff -> IO TestSuite
applyTestSuiteDiff :: Verbosity -> TestSuite -> TestSuite -> IO TestSuite
applyTestSuiteDiff Verbosity
verbosity TestSuite
test TestSuite
diff =
  case TestSuite -> TestSuite -> [IllegalComponentDiffReason]
illegalTestSuiteDiffReasons TestSuite
test TestSuite
diff of
    [] -> TestSuite -> IO TestSuite
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestSuite -> IO TestSuite) -> TestSuite -> IO TestSuite
forall a b. (a -> b) -> a -> b
$ TestSuite
test TestSuite -> TestSuite -> TestSuite
forall a. Semigroup a => a -> a -> a
<> TestSuite
diff
    (IllegalComponentDiffReason
r : [IllegalComponentDiffReason]
rs) ->
      Verbosity -> CabalException -> IO TestSuite
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO TestSuite) -> CabalException -> IO TestSuite
forall a b. (a -> b) -> a -> b
$
        SetupHooksException -> CabalException
SetupHooksException (SetupHooksException -> CabalException)
-> SetupHooksException -> CabalException
forall a b. (a -> b) -> a -> b
$
          CannotApplyComponentDiffReason -> SetupHooksException
CannotApplyComponentDiff (CannotApplyComponentDiffReason -> SetupHooksException)
-> CannotApplyComponentDiffReason -> SetupHooksException
forall a b. (a -> b) -> a -> b
$
            Component
-> NonEmpty IllegalComponentDiffReason
-> CannotApplyComponentDiffReason
IllegalComponentDiff (TestSuite -> Component
CTest TestSuite
test) (IllegalComponentDiffReason
r IllegalComponentDiffReason
-> [IllegalComponentDiffReason]
-> NonEmpty IllegalComponentDiffReason
forall a. a -> [a] -> NonEmpty a
NE.:| [IllegalComponentDiffReason]
rs)

illegalTestSuiteDiffReasons :: TestSuite -> TestSuiteDiff -> [IllegalComponentDiffReason]
illegalTestSuiteDiffReasons :: TestSuite -> TestSuite -> [IllegalComponentDiffReason]
illegalTestSuiteDiffReasons
  TestSuite
test
  TestSuite
    { testName :: TestSuite -> UnqualComponentName
testName = UnqualComponentName
nm
    , testInterface :: TestSuite -> TestSuiteInterface
testInterface = TestSuiteInterface
iface
    , testCodeGenerators :: TestSuite -> [String]
testCodeGenerators = [String]
gens
    , testBuildInfo :: TestSuite -> BuildInfo
testBuildInfo = BuildInfo
bi
    } =
    [ IllegalComponentDiffReason
CannotChangeName
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UnqualComponentName
nm UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== TestSuite -> UnqualComponentName
testName TestSuite
emptyTestSuite Bool -> Bool -> Bool
|| UnqualComponentName
nm UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== TestSuite -> UnqualComponentName
testName TestSuite
test
    ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ [ String -> IllegalComponentDiffReason
CannotChangeComponentField String
"testInterface"
         | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TestSuiteInterface
iface TestSuiteInterface -> TestSuiteInterface -> Bool
forall a. Eq a => a -> a -> Bool
== TestSuite -> TestSuiteInterface
testInterface TestSuite
emptyTestSuite Bool -> Bool -> Bool
|| TestSuiteInterface
iface TestSuiteInterface -> TestSuiteInterface -> Bool
forall a. Eq a => a -> a -> Bool
== TestSuite -> TestSuiteInterface
testInterface TestSuite
test
         ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ [ String -> IllegalComponentDiffReason
CannotChangeComponentField String
"testCodeGenerators"
         | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String]
gens [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== TestSuite -> [String]
testCodeGenerators TestSuite
emptyTestSuite Bool -> Bool -> Bool
|| [String]
gens [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== TestSuite -> [String]
testCodeGenerators TestSuite
test
         ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> BuildInfo -> [IllegalComponentDiffReason]
illegalBuildInfoDiffReasons (TestSuite -> BuildInfo
testBuildInfo TestSuite
test) BuildInfo
bi

applyBenchmarkDiff :: Verbosity -> Benchmark -> BenchmarkDiff -> IO Benchmark
applyBenchmarkDiff :: Verbosity -> Benchmark -> Benchmark -> IO Benchmark
applyBenchmarkDiff Verbosity
verbosity Benchmark
bench Benchmark
diff =
  case Benchmark -> Benchmark -> [IllegalComponentDiffReason]
illegalBenchmarkDiffReasons Benchmark
bench Benchmark
diff of
    [] -> Benchmark -> IO Benchmark
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Benchmark -> IO Benchmark) -> Benchmark -> IO Benchmark
forall a b. (a -> b) -> a -> b
$ Benchmark
bench Benchmark -> Benchmark -> Benchmark
forall a. Semigroup a => a -> a -> a
<> Benchmark
diff
    (IllegalComponentDiffReason
r : [IllegalComponentDiffReason]
rs) ->
      Verbosity -> CabalException -> IO Benchmark
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO Benchmark) -> CabalException -> IO Benchmark
forall a b. (a -> b) -> a -> b
$
        SetupHooksException -> CabalException
SetupHooksException (SetupHooksException -> CabalException)
-> SetupHooksException -> CabalException
forall a b. (a -> b) -> a -> b
$
          CannotApplyComponentDiffReason -> SetupHooksException
CannotApplyComponentDiff (CannotApplyComponentDiffReason -> SetupHooksException)
-> CannotApplyComponentDiffReason -> SetupHooksException
forall a b. (a -> b) -> a -> b
$
            Component
-> NonEmpty IllegalComponentDiffReason
-> CannotApplyComponentDiffReason
IllegalComponentDiff (Benchmark -> Component
CBench Benchmark
bench) (IllegalComponentDiffReason
r IllegalComponentDiffReason
-> [IllegalComponentDiffReason]
-> NonEmpty IllegalComponentDiffReason
forall a. a -> [a] -> NonEmpty a
NE.:| [IllegalComponentDiffReason]
rs)

illegalBenchmarkDiffReasons :: Benchmark -> BenchmarkDiff -> [IllegalComponentDiffReason]
illegalBenchmarkDiffReasons :: Benchmark -> Benchmark -> [IllegalComponentDiffReason]
illegalBenchmarkDiffReasons
  Benchmark
bench
  Benchmark
    { benchmarkName :: Benchmark -> UnqualComponentName
benchmarkName = UnqualComponentName
nm
    , benchmarkInterface :: Benchmark -> BenchmarkInterface
benchmarkInterface = BenchmarkInterface
iface
    , benchmarkBuildInfo :: Benchmark -> BuildInfo
benchmarkBuildInfo = BuildInfo
bi
    } =
    [ IllegalComponentDiffReason
CannotChangeName
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ UnqualComponentName
nm UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== Benchmark -> UnqualComponentName
benchmarkName Benchmark
emptyBenchmark Bool -> Bool -> Bool
|| UnqualComponentName
nm UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== Benchmark -> UnqualComponentName
benchmarkName Benchmark
bench
    ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ [ String -> IllegalComponentDiffReason
CannotChangeComponentField String
"benchmarkInterface"
         | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ BenchmarkInterface
iface BenchmarkInterface -> BenchmarkInterface -> Bool
forall a. Eq a => a -> a -> Bool
== Benchmark -> BenchmarkInterface
benchmarkInterface Benchmark
emptyBenchmark Bool -> Bool -> Bool
|| BenchmarkInterface
iface BenchmarkInterface -> BenchmarkInterface -> Bool
forall a. Eq a => a -> a -> Bool
== Benchmark -> BenchmarkInterface
benchmarkInterface Benchmark
bench
         ]
      [IllegalComponentDiffReason]
-> [IllegalComponentDiffReason] -> [IllegalComponentDiffReason]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> BuildInfo -> [IllegalComponentDiffReason]
illegalBuildInfoDiffReasons (Benchmark -> BuildInfo
benchmarkBuildInfo Benchmark
bench) BuildInfo
bi

illegalBuildInfoDiffReasons :: BuildInfo -> BuildInfoDiff -> [IllegalComponentDiffReason]
illegalBuildInfoDiffReasons :: BuildInfo -> BuildInfo -> [IllegalComponentDiffReason]
illegalBuildInfoDiffReasons
  BuildInfo
bi
  BuildInfo
    { buildable :: BuildInfo -> Bool
buildable = Bool
can_build
    , buildTools :: BuildInfo -> [LegacyExeDependency]
buildTools = [LegacyExeDependency]
build_tools
    , buildToolDepends :: BuildInfo -> [ExeDependency]
buildToolDepends = [ExeDependency]
build_tools_depends
    , pkgconfigDepends :: BuildInfo -> [PkgconfigDependency]
pkgconfigDepends = [PkgconfigDependency]
pkgconfig_depends
    , frameworks :: BuildInfo -> [RelativePath Framework 'File]
frameworks = [RelativePath Framework 'File]
fworks
    , targetBuildDepends :: BuildInfo -> [Dependency]
targetBuildDepends = [Dependency]
target_build_depends
    } =
    (String -> IllegalComponentDiffReason)
-> [String] -> [IllegalComponentDiffReason]
forall a b. (a -> b) -> [a] -> [b]
map String -> IllegalComponentDiffReason
CannotChangeBuildInfoField ([String] -> [IllegalComponentDiffReason])
-> [String] -> [IllegalComponentDiffReason]
forall a b. (a -> b) -> a -> b
$
      [ String
"buildable"
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
can_build Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== BuildInfo -> Bool
buildable BuildInfo
bi Bool -> Bool -> Bool
|| Bool
can_build Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== BuildInfo -> Bool
buildable BuildInfo
emptyBuildInfo
      ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"buildTools"
           | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [LegacyExeDependency]
build_tools [LegacyExeDependency] -> [LegacyExeDependency] -> Bool
forall a. Eq a => a -> a -> Bool
== BuildInfo -> [LegacyExeDependency]
buildTools BuildInfo
bi Bool -> Bool -> Bool
|| [LegacyExeDependency]
build_tools [LegacyExeDependency] -> [LegacyExeDependency] -> Bool
forall a. Eq a => a -> a -> Bool
== BuildInfo -> [LegacyExeDependency]
buildTools BuildInfo
emptyBuildInfo
           ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"buildToolsDepends"
           | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ExeDependency]
build_tools_depends [ExeDependency] -> [ExeDependency] -> Bool
forall a. Eq a => a -> a -> Bool
== BuildInfo -> [ExeDependency]
buildToolDepends BuildInfo
bi Bool -> Bool -> Bool
|| [ExeDependency]
build_tools_depends [ExeDependency] -> [ExeDependency] -> Bool
forall a. Eq a => a -> a -> Bool
== BuildInfo -> [ExeDependency]
buildToolDepends BuildInfo
emptyBuildInfo
           ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"pkgconfigDepends"
           | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [PkgconfigDependency]
pkgconfig_depends [PkgconfigDependency] -> [PkgconfigDependency] -> Bool
forall a. Eq a => a -> a -> Bool
== BuildInfo -> [PkgconfigDependency]
pkgconfigDepends BuildInfo
bi Bool -> Bool -> Bool
|| [PkgconfigDependency]
pkgconfig_depends [PkgconfigDependency] -> [PkgconfigDependency] -> Bool
forall a. Eq a => a -> a -> Bool
== BuildInfo -> [PkgconfigDependency]
pkgconfigDepends BuildInfo
emptyBuildInfo
           ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"frameworks"
           | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [RelativePath Framework 'File]
fworks [RelativePath Framework 'File]
-> [RelativePath Framework 'File] -> Bool
forall a. Eq a => a -> a -> Bool
== BuildInfo -> [RelativePath Framework 'File]
frameworks BuildInfo
bi Bool -> Bool -> Bool
|| [RelativePath Framework 'File]
fworks [RelativePath Framework 'File]
-> [RelativePath Framework 'File] -> Bool
forall a. Eq a => a -> a -> Bool
== BuildInfo -> [RelativePath Framework 'File]
frameworks BuildInfo
emptyBuildInfo
           ]
        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"targetBuildDepends"
           | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Dependency]
target_build_depends [Dependency] -> [Dependency] -> Bool
forall a. Eq a => a -> a -> Bool
== BuildInfo -> [Dependency]
targetBuildDepends BuildInfo
bi Bool -> Bool -> Bool
|| [Dependency]
target_build_depends [Dependency] -> [Dependency] -> Bool
forall a. Eq a => a -> a -> Bool
== BuildInfo -> [Dependency]
targetBuildDepends BuildInfo
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 :: forall (m :: * -> *).
Applicative m =>
(Component -> m Component)
-> PackageDescription -> m PackageDescription
traverseComponents Component -> m Component
f PackageDescription
pd =
  Maybe Library
-> [Library]
-> [ForeignLib]
-> [Executable]
-> [TestSuite]
-> [Benchmark]
-> PackageDescription
upd_pd
    (Maybe Library
 -> [Library]
 -> [ForeignLib]
 -> [Executable]
 -> [TestSuite]
 -> [Benchmark]
 -> PackageDescription)
-> m (Maybe Library)
-> m ([Library]
      -> [ForeignLib]
      -> [Executable]
      -> [TestSuite]
      -> [Benchmark]
      -> PackageDescription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Library -> m Library) -> Maybe Library -> m (Maybe Library)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Library -> m Library
f_lib (PackageDescription -> Maybe Library
library PackageDescription
pd)
    m ([Library]
   -> [ForeignLib]
   -> [Executable]
   -> [TestSuite]
   -> [Benchmark]
   -> PackageDescription)
-> m [Library]
-> m ([ForeignLib]
      -> [Executable]
      -> [TestSuite]
      -> [Benchmark]
      -> PackageDescription)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Library -> m Library) -> [Library] -> m [Library]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Library -> m Library
f_lib (PackageDescription -> [Library]
subLibraries PackageDescription
pd)
    m ([ForeignLib]
   -> [Executable]
   -> [TestSuite]
   -> [Benchmark]
   -> PackageDescription)
-> m [ForeignLib]
-> m ([Executable]
      -> [TestSuite] -> [Benchmark] -> PackageDescription)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ForeignLib -> m ForeignLib) -> [ForeignLib] -> m [ForeignLib]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ForeignLib -> m ForeignLib
f_flib (PackageDescription -> [ForeignLib]
foreignLibs PackageDescription
pd)
    m ([Executable]
   -> [TestSuite] -> [Benchmark] -> PackageDescription)
-> m [Executable]
-> m ([TestSuite] -> [Benchmark] -> PackageDescription)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Executable -> m Executable) -> [Executable] -> m [Executable]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Executable -> m Executable
f_exe (PackageDescription -> [Executable]
executables PackageDescription
pd)
    m ([TestSuite] -> [Benchmark] -> PackageDescription)
-> m [TestSuite] -> m ([Benchmark] -> PackageDescription)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TestSuite -> m TestSuite) -> [TestSuite] -> m [TestSuite]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse TestSuite -> m TestSuite
f_test (PackageDescription -> [TestSuite]
testSuites PackageDescription
pd)
    m ([Benchmark] -> PackageDescription)
-> m [Benchmark] -> m PackageDescription
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Benchmark -> m Benchmark) -> [Benchmark] -> m [Benchmark]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Benchmark -> m Benchmark
f_bench (PackageDescription -> [Benchmark]
benchmarks PackageDescription
pd)
  where
    f_lib :: Library -> m Library
f_lib Library
lib = \case { CLib Library
lib' -> Library
lib'; Component
c -> Component -> Component -> Library
forall {b}. Component -> Component -> b
mismatch (Library -> Component
CLib Library
lib) Component
c } (Component -> Library) -> m Component -> m Library
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Component -> m Component
f (Library -> Component
CLib Library
lib)
    f_flib :: ForeignLib -> m ForeignLib
f_flib ForeignLib
flib = \case { CFLib ForeignLib
flib' -> ForeignLib
flib'; Component
c -> Component -> Component -> ForeignLib
forall {b}. Component -> Component -> b
mismatch (ForeignLib -> Component
CFLib ForeignLib
flib) Component
c } (Component -> ForeignLib) -> m Component -> m ForeignLib
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Component -> m Component
f (ForeignLib -> Component
CFLib ForeignLib
flib)
    f_exe :: Executable -> m Executable
f_exe Executable
exe = \case { CExe Executable
exe' -> Executable
exe'; Component
c -> Component -> Component -> Executable
forall {b}. Component -> Component -> b
mismatch (Executable -> Component
CExe Executable
exe) Component
c } (Component -> Executable) -> m Component -> m Executable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Component -> m Component
f (Executable -> Component
CExe Executable
exe)
    f_test :: TestSuite -> m TestSuite
f_test TestSuite
test = \case { CTest TestSuite
test' -> TestSuite
test'; Component
c -> Component -> Component -> TestSuite
forall {b}. Component -> Component -> b
mismatch (TestSuite -> Component
CTest TestSuite
test) Component
c } (Component -> TestSuite) -> m Component -> m TestSuite
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Component -> m Component
f (TestSuite -> Component
CTest TestSuite
test)
    f_bench :: Benchmark -> m Benchmark
f_bench Benchmark
bench = \case { CBench Benchmark
bench' -> Benchmark
bench'; Component
c -> Component -> Component -> Benchmark
forall {b}. Component -> Component -> b
mismatch (Benchmark -> Component
CBench Benchmark
bench) Component
c } (Component -> Benchmark) -> m Component -> m Benchmark
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Component -> m Component
f (Benchmark -> Component
CBench Benchmark
bench)

    upd_pd :: Maybe Library
-> [Library]
-> [ForeignLib]
-> [Executable]
-> [TestSuite]
-> [Benchmark]
-> PackageDescription
upd_pd Maybe Library
lib [Library]
sublibs [ForeignLib]
flibs [Executable]
exes [TestSuite]
tests [Benchmark]
benchs =
      PackageDescription
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 :: Component -> Component -> b
mismatch Component
c1 Component
c2 =
      String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$
        String
"Mismatched component types: "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ ComponentName -> String
showComponentName (Component -> ComponentName
componentName Component
c1)
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ ComponentName -> String
showComponentName (Component -> ComponentName
componentName Component
c2)
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
{-# INLINEABLE traverseComponents #-}

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

forComponents_ :: PackageDescription -> (Component -> IO ()) -> IO ()
forComponents_ :: PackageDescription -> (Component -> IO ()) -> IO ()
forComponents_ PackageDescription
pd Component -> IO ()
f = Const (IO ()) PackageDescription -> IO ()
forall {k} a (b :: k). Const a b -> a
getConst (Const (IO ()) PackageDescription -> IO ())
-> Const (IO ()) PackageDescription -> IO ()
forall a b. (a -> b) -> a -> b
$ (Component -> Const (IO ()) Component)
-> PackageDescription -> Const (IO ()) PackageDescription
forall (m :: * -> *).
Applicative m =>
(Component -> m Component)
-> PackageDescription -> m PackageDescription
traverseComponents (IO () -> Const (IO ()) Component
forall {k} a (b :: k). a -> Const a b
Const (IO () -> Const (IO ()) Component)
-> (Component -> IO ()) -> Component -> Const (IO ()) Component
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Component -> IO ()
f) PackageDescription
pd

applyComponentDiff
  :: Verbosity
  -> Component
  -> ComponentDiff
  -> IO Component
applyComponentDiff :: Verbosity -> Component -> ComponentDiff -> IO Component
applyComponentDiff Verbosity
verbosity Component
comp (ComponentDiff Component
diff)
  | CLib Library
lib <- Component
comp
  , CLib Library
lib_diff <- Component
diff =
      Library -> Component
CLib (Library -> Component) -> IO Library -> IO Component
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> Library -> Library -> IO Library
applyLibraryDiff Verbosity
verbosity Library
lib Library
lib_diff
  | CFLib ForeignLib
flib <- Component
comp
  , CFLib ForeignLib
flib_diff <- Component
diff =
      ForeignLib -> Component
CFLib (ForeignLib -> Component) -> IO ForeignLib -> IO Component
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> ForeignLib -> ForeignLib -> IO ForeignLib
applyForeignLibDiff Verbosity
verbosity ForeignLib
flib ForeignLib
flib_diff
  | CExe Executable
exe <- Component
comp
  , CExe Executable
exe_diff <- Component
diff =
      Executable -> Component
CExe (Executable -> Component) -> IO Executable -> IO Component
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> Executable -> Executable -> IO Executable
applyExecutableDiff Verbosity
verbosity Executable
exe Executable
exe_diff
  | CTest TestSuite
test <- Component
comp
  , CTest TestSuite
test_diff <- Component
diff =
      TestSuite -> Component
CTest (TestSuite -> Component) -> IO TestSuite -> IO Component
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> TestSuite -> TestSuite -> IO TestSuite
applyTestSuiteDiff Verbosity
verbosity TestSuite
test TestSuite
test_diff
  | CBench Benchmark
bench <- Component
comp
  , CBench Benchmark
bench_diff <- Component
diff =
      Benchmark -> Component
CBench (Benchmark -> Component) -> IO Benchmark -> IO Component
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity -> Benchmark -> Benchmark -> IO Benchmark
applyBenchmarkDiff Verbosity
verbosity Benchmark
bench Benchmark
bench_diff
  | Bool
otherwise =
      CannotApplyComponentDiffReason -> IO Component
componentDiffError (CannotApplyComponentDiffReason -> IO Component)
-> CannotApplyComponentDiffReason -> IO Component
forall a b. (a -> b) -> a -> b
$ Component -> Component -> CannotApplyComponentDiffReason
MismatchedComponentTypes Component
comp Component
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 :: CannotApplyComponentDiffReason -> IO Component
componentDiffError CannotApplyComponentDiffReason
err =
      Verbosity -> CabalException -> IO Component
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO Component) -> CabalException -> IO Component
forall a b. (a -> b) -> a -> b
$
        SetupHooksException -> CabalException
SetupHooksException (SetupHooksException -> CabalException)
-> SetupHooksException -> CabalException
forall a b. (a -> b) -> a -> b
$
          CannotApplyComponentDiffReason -> SetupHooksException
CannotApplyComponentDiff CannotApplyComponentDiffReason
err

--------------------------------------------------------------------------------
-- Running pre-build rules

-- | Run all pre-build rules.
--
-- 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
  -> Map RuleId Rule
  -> IO ()
executeRules :: Verbosity
-> LocalBuildInfo -> TargetInfo -> Map RuleId Rule -> IO ()
executeRules =
  SScope 'User
-> (RuleId
    -> RuleDynDepsCmd 'User -> IO (Maybe ([Dependency], ByteString)))
-> (RuleId -> RuleExecCmd 'User -> IO ())
-> Verbosity
-> LocalBuildInfo
-> TargetInfo
-> Map RuleId Rule
-> IO ()
forall (userOrSystem :: Scope).
SScope userOrSystem
-> (RuleId
    -> RuleDynDepsCmd userOrSystem
    -> IO (Maybe ([Dependency], ByteString)))
-> (RuleId -> RuleExecCmd userOrSystem -> IO ())
-> Verbosity
-> LocalBuildInfo
-> TargetInfo
-> Map RuleId (RuleData userOrSystem)
-> IO ()
executeRulesUserOrSystem
    SScope 'User
SUser
    (\RuleId
_rId RuleDynDepsCmd 'User
cmd -> Maybe (IO ([Dependency], ByteString))
-> IO (Maybe ([Dependency], ByteString))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => Maybe (f a) -> f (Maybe a)
sequenceA (Maybe (IO ([Dependency], ByteString))
 -> IO (Maybe ([Dependency], ByteString)))
-> Maybe (IO ([Dependency], ByteString))
-> IO (Maybe ([Dependency], ByteString))
forall a b. (a -> b) -> a -> b
$ RuleDynDepsCmd 'User -> Maybe (IO ([Dependency], ByteString))
runRuleDynDepsCmd RuleDynDepsCmd 'User
cmd)
    (\RuleId
_rId RuleExecCmd 'User
cmd -> RuleExecCmd 'User -> IO ()
runRuleExecCmd RuleExecCmd 'User
cmd)

-- | Like 'executeRules', except it can be used when communicating with
-- an external hooks executable.
executeRulesUserOrSystem
  :: forall userOrSystem
   . SScope userOrSystem
  -> (RuleId -> RuleDynDepsCmd userOrSystem -> IO (Maybe ([Rule.Dependency], LBS.ByteString)))
  -> (RuleId -> RuleExecCmd userOrSystem -> IO ())
  -> Verbosity
  -> LocalBuildInfo
  -> TargetInfo
  -> Map RuleId (RuleData userOrSystem)
  -> IO ()
executeRulesUserOrSystem :: forall (userOrSystem :: Scope).
SScope userOrSystem
-> (RuleId
    -> RuleDynDepsCmd userOrSystem
    -> IO (Maybe ([Dependency], ByteString)))
-> (RuleId -> RuleExecCmd userOrSystem -> IO ())
-> Verbosity
-> LocalBuildInfo
-> TargetInfo
-> Map RuleId (RuleData userOrSystem)
-> IO ()
executeRulesUserOrSystem SScope userOrSystem
scope RuleId
-> RuleDynDepsCmd userOrSystem
-> IO (Maybe ([Dependency], ByteString))
runDepsCmdData RuleId -> RuleExecCmd userOrSystem -> IO ()
runCmdData Verbosity
verbosity LocalBuildInfo
lbi TargetInfo
tgtInfo Map RuleId (RuleData userOrSystem)
allRules = do
  -- Compute all extra dynamic dependency edges.
  dynDepsEdges <-
    ((RuleId
  -> RuleData userOrSystem -> IO (Maybe ([Dependency], ByteString)))
 -> Map RuleId (RuleData userOrSystem)
 -> IO (Map RuleId ([Dependency], ByteString)))
-> Map RuleId (RuleData userOrSystem)
-> (RuleId
    -> RuleData userOrSystem -> IO (Maybe ([Dependency], ByteString)))
-> IO (Map RuleId ([Dependency], ByteString))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (RuleId
 -> RuleData userOrSystem -> IO (Maybe ([Dependency], ByteString)))
-> Map RuleId (RuleData userOrSystem)
-> IO (Map RuleId ([Dependency], ByteString))
forall (f :: * -> *) k a b.
Applicative f =>
(k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)
Map.traverseMaybeWithKey Map RuleId (RuleData userOrSystem)
allRules ((RuleId
  -> RuleData userOrSystem -> IO (Maybe ([Dependency], ByteString)))
 -> IO (Map RuleId ([Dependency], ByteString)))
-> (RuleId
    -> RuleData userOrSystem -> IO (Maybe ([Dependency], ByteString)))
-> IO (Map RuleId ([Dependency], ByteString))
forall a b. (a -> b) -> a -> b
$
      \RuleId
rId (Rule{ruleCommands :: forall (scope :: Scope). RuleData scope -> RuleCmds scope
ruleCommands = RuleCmds userOrSystem
cmds}) ->
        RuleId
-> RuleDynDepsCmd userOrSystem
-> IO (Maybe ([Dependency], ByteString))
runDepsCmdData RuleId
rId (RuleCmds userOrSystem -> RuleDynDepsCmd userOrSystem
forall (scope :: Scope). RuleCmds scope -> RuleDynDepsCmd scope
ruleDepsCmd RuleCmds userOrSystem
cmds)

  -- Create a build graph of all the rules, with static and dynamic dependencies
  -- as edges.
  let
    (ruleGraph, ruleFromVertex, vertexFromRuleId) =
      Graph.graphFromEdges
        [ (rule, rId, nub $ mapMaybe directRuleDependencyMaybe allDeps)
        | (rId, rule) <- Map.toList allRules
        , let dynDeps = [Dependency] -> Maybe [Dependency] -> [Dependency]
forall a. a -> Maybe a -> a
fromMaybe [] (([Dependency], ByteString) -> [Dependency]
forall a b. (a, b) -> a
fst (([Dependency], ByteString) -> [Dependency])
-> Maybe ([Dependency], ByteString) -> Maybe [Dependency]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RuleId
-> Map RuleId ([Dependency], ByteString)
-> Maybe ([Dependency], ByteString)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RuleId
rId Map RuleId ([Dependency], ByteString)
dynDepsEdges)
              allDeps = RuleData userOrSystem -> [Dependency]
forall (scope :: Scope). RuleData scope -> [Dependency]
staticDependencies RuleData userOrSystem
rule [Dependency] -> [Dependency] -> [Dependency]
forall a. [a] -> [a] -> [a]
++ [Dependency]
dynDeps
        ]

    -- Topologically sort the graph of rules.
    sccs = Graph -> [Tree Int]
Graph.scc Graph
ruleGraph
    cycles = (Tree Int
 -> Maybe
      ((RuleData userOrSystem, RuleId, [RuleId]),
       [Tree (RuleData userOrSystem, RuleId, [RuleId])]))
-> [Tree Int]
-> [((RuleData userOrSystem, RuleId, [RuleId]),
     [Tree (RuleData userOrSystem, RuleId, [RuleId])])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Tree Int
  -> Maybe
       ((RuleData userOrSystem, RuleId, [RuleId]),
        [Tree (RuleData userOrSystem, RuleId, [RuleId])]))
 -> [Tree Int]
 -> [((RuleData userOrSystem, RuleId, [RuleId]),
      [Tree (RuleData userOrSystem, RuleId, [RuleId])])])
-> (Tree Int
    -> Maybe
         ((RuleData userOrSystem, RuleId, [RuleId]),
          [Tree (RuleData userOrSystem, RuleId, [RuleId])]))
-> [Tree Int]
-> [((RuleData userOrSystem, RuleId, [RuleId]),
     [Tree (RuleData userOrSystem, RuleId, [RuleId])])]
forall a b. (a -> b) -> a -> b
$ \(Graph.Node Int
v0 [Tree Int]
subforest) ->
      case [Tree Int]
subforest of
        []
          | r :: (RuleData userOrSystem, RuleId, [RuleId])
r@(RuleData userOrSystem
_, RuleId
rId, [RuleId]
deps) <- Int -> (RuleData userOrSystem, RuleId, [RuleId])
ruleFromVertex Int
v0 ->
              if RuleId
rId RuleId -> [RuleId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RuleId]
deps
                then ((RuleData userOrSystem, RuleId, [RuleId]),
 [Tree (RuleData userOrSystem, RuleId, [RuleId])])
-> Maybe
     ((RuleData userOrSystem, RuleId, [RuleId]),
      [Tree (RuleData userOrSystem, RuleId, [RuleId])])
forall a. a -> Maybe a
Just ((RuleData userOrSystem, RuleId, [RuleId])
r, [])
                else Maybe
  ((RuleData userOrSystem, RuleId, [RuleId]),
   [Tree (RuleData userOrSystem, RuleId, [RuleId])])
forall a. Maybe a
Nothing
        Tree Int
v : [Tree Int]
vs ->
          ((RuleData userOrSystem, RuleId, [RuleId]),
 [Tree (RuleData userOrSystem, RuleId, [RuleId])])
-> Maybe
     ((RuleData userOrSystem, RuleId, [RuleId]),
      [Tree (RuleData userOrSystem, RuleId, [RuleId])])
forall a. a -> Maybe a
Just
            ( Int -> (RuleData userOrSystem, RuleId, [RuleId])
ruleFromVertex Int
v0
            , (Tree Int -> Tree (RuleData userOrSystem, RuleId, [RuleId]))
-> [Tree Int] -> [Tree (RuleData userOrSystem, RuleId, [RuleId])]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> (RuleData userOrSystem, RuleId, [RuleId]))
-> Tree Int -> Tree (RuleData userOrSystem, RuleId, [RuleId])
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> (RuleData userOrSystem, RuleId, [RuleId])
ruleFromVertex) (Tree Int
v Tree Int -> [Tree Int] -> [Tree Int]
forall a. a -> [a] -> [a]
: [Tree Int]
vs)
            )

    -- Compute demanded rules.
    --
    -- SetupHooks TODO: maybe requiring all generated modules to appear
    -- in autogen-modules is excessive; we can look through all modules instead.
    autogenModPaths =
      (ModuleName -> RelativePath Source 'File)
-> [ModuleName] -> [RelativePath Source 'File]
forall a b. (a -> b) -> [a] -> [b]
map (\ModuleName
m -> ModuleName -> RelativePath Source 'File
forall (allowAbsolute :: AllowAbsolute).
ModuleName -> SymbolicPathX allowAbsolute Source 'File
moduleNameSymbolicPath ModuleName
m RelativePath Source 'File -> String -> RelativePath Source 'File
forall p. FileLike p => p -> String -> p
<.> String
"hs") ([ModuleName] -> [RelativePath Source 'File])
-> [ModuleName] -> [RelativePath Source 'File]
forall a b. (a -> b) -> a -> b
$
        BuildInfo -> [ModuleName]
autogenModules (BuildInfo -> [ModuleName]) -> BuildInfo -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
          Component -> BuildInfo
componentBuildInfo (Component -> BuildInfo) -> Component -> BuildInfo
forall a b. (a -> b) -> a -> b
$
            TargetInfo -> Component
targetComponent TargetInfo
tgtInfo
    leafRule_maybe (RuleId
rId, RuleData userOrSystem
r) =
      if (RelativePath Source 'File -> Bool)
-> [RelativePath Source 'File] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((RuleData userOrSystem
r RuleData userOrSystem -> Location -> Bool
forall (scope :: Scope). RuleData scope -> Location -> Bool
`ruleOutputsLocation`) (Location -> Bool)
-> (RelativePath Source 'File -> Location)
-> RelativePath Source 'File
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymbolicPath Pkg ('Dir Source)
-> RelativePath Source 'File -> Location
forall baseDir.
SymbolicPath Pkg ('Dir baseDir)
-> RelativePath baseDir 'File -> Location
Location SymbolicPath Pkg ('Dir Source)
compAutogenDir)) [RelativePath Source 'File]
autogenModPaths
        then RuleId -> Maybe Int
vertexFromRuleId RuleId
rId
        else Maybe Int
forall a. Maybe a
Nothing
    leafRules = ((RuleId, RuleData userOrSystem) -> Maybe Int)
-> [(RuleId, RuleData userOrSystem)] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RuleId, RuleData userOrSystem) -> Maybe Int
leafRule_maybe ([(RuleId, RuleData userOrSystem)] -> [Int])
-> [(RuleId, RuleData userOrSystem)] -> [Int]
forall a b. (a -> b) -> a -> b
$ Map RuleId (RuleData userOrSystem)
-> [(RuleId, RuleData userOrSystem)]
forall k a. Map k a -> [(k, a)]
Map.toList Map RuleId (RuleData userOrSystem)
allRules
    demandedRuleVerts = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList ([Int] -> Set Int) -> [Int] -> Set Int
forall a b. (a -> b) -> a -> b
$ (Int -> [Int]) -> [Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Graph -> Int -> [Int]
Graph.reachable Graph
ruleGraph) [Int]
leafRules
    nonDemandedRuleVerts = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (Graph -> [Int]
Graph.vertices Graph
ruleGraph) Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set Int
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.
    ((RuleData userOrSystem, RuleId, [RuleId]),
 [Tree (RuleData userOrSystem, RuleId, [RuleId])])
r : [((RuleData userOrSystem, RuleId, [RuleId]),
  [Tree (RuleData userOrSystem, RuleId, [RuleId])])]
rs ->
      let getRule :: ((RuleData userOrSystem, RuleId, [RuleId]),
 [Tree (RuleData userOrSystem, RuleId, [RuleId])])
-> (RuleBinary, [Tree RuleBinary])
getRule ((RuleData userOrSystem
ru, RuleId
_, [RuleId]
_), [Tree (RuleData userOrSystem, RuleId, [RuleId])]
js) = (RuleData userOrSystem -> RuleBinary
toRuleBinary RuleData userOrSystem
ru, (Tree (RuleData userOrSystem, RuleId, [RuleId]) -> Tree RuleBinary)
-> [Tree (RuleData userOrSystem, RuleId, [RuleId])]
-> [Tree RuleBinary]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((RuleData userOrSystem, RuleId, [RuleId]) -> RuleBinary)
-> Tree (RuleData userOrSystem, RuleId, [RuleId])
-> Tree RuleBinary
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(RuleData userOrSystem
rv, RuleId
_, [RuleId]
_) -> RuleData userOrSystem -> RuleBinary
toRuleBinary RuleData userOrSystem
rv)) [Tree (RuleData userOrSystem, RuleId, [RuleId])]
js)
       in RulesException -> IO ()
errorOut (RulesException -> IO ()) -> RulesException -> IO ()
forall a b. (a -> b) -> a -> b
$
            NonEmpty (RuleBinary, [Tree RuleBinary]) -> RulesException
CyclicRuleDependencies (NonEmpty (RuleBinary, [Tree RuleBinary]) -> RulesException)
-> NonEmpty (RuleBinary, [Tree RuleBinary]) -> RulesException
forall a b. (a -> b) -> a -> b
$
              (((RuleData userOrSystem, RuleId, [RuleId]),
  [Tree (RuleData userOrSystem, RuleId, [RuleId])])
 -> (RuleBinary, [Tree RuleBinary]))
-> NonEmpty
     ((RuleData userOrSystem, RuleId, [RuleId]),
      [Tree (RuleData userOrSystem, RuleId, [RuleId])])
-> NonEmpty (RuleBinary, [Tree RuleBinary])
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RuleData userOrSystem, RuleId, [RuleId]),
 [Tree (RuleData userOrSystem, RuleId, [RuleId])])
-> (RuleBinary, [Tree RuleBinary])
getRule (((RuleData userOrSystem, RuleId, [RuleId]),
 [Tree (RuleData userOrSystem, RuleId, [RuleId])])
r ((RuleData userOrSystem, RuleId, [RuleId]),
 [Tree (RuleData userOrSystem, RuleId, [RuleId])])
-> [((RuleData userOrSystem, RuleId, [RuleId]),
     [Tree (RuleData userOrSystem, RuleId, [RuleId])])]
-> NonEmpty
     ((RuleData userOrSystem, RuleId, [RuleId]),
      [Tree (RuleData userOrSystem, RuleId, [RuleId])])
forall a. a -> [a] -> NonEmpty a
NE.:| [((RuleData userOrSystem, RuleId, [RuleId]),
  [Tree (RuleData userOrSystem, RuleId, [RuleId])])]
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.
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set Int -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Int
nonDemandedRuleVerts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
            String
"The following rules are not demanded and will not be run:"
              String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ [ String
"  - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RuleId -> String
forall a. Show a => a -> String
show RuleId
rId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
","
                  , String
"    generating " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Location] -> String
forall a. Show a => a -> String
show (NonEmpty Location -> [Location]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Location -> [Location])
-> NonEmpty Location -> [Location]
forall a b. (a -> b) -> a -> b
$ RuleData userOrSystem -> NonEmpty Location
forall (scope :: Scope). RuleData scope -> NonEmpty Location
results RuleData userOrSystem
r)
                  ]
                | Int
v <- Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
nonDemandedRuleVerts
                , let (RuleData userOrSystem
r, RuleId
rId, [RuleId]
_) = Int -> (RuleData userOrSystem, RuleId, [RuleId])
ruleFromVertex Int
v
                ]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"Possible reasons for this error:"
                 , String
"  - Some autogenerated modules were not declared"
                 , String
"    (in the package description or in the pre-configure hooks)"
                 , String
"  - The output location for an autogenerated module is incorrect,"
                 , String
"    (e.g. the file extension is incorrect, or"
                 , String
"     it is not in the appropriate 'autogenComponentModules' directory)"
                 ]

      -- Run all the demanded rules, in dependency order.
      [Tree Int] -> (Tree Int -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Tree Int]
sccs ((Tree Int -> IO ()) -> IO ()) -> (Tree Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Graph.Node Int
ruleVertex [Tree Int]
_) ->
        -- Don't run a rule unless it is demanded.
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
ruleVertex Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
nonDemandedRuleVerts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          let ( r :: RuleData userOrSystem
r@Rule
                  { ruleCommands :: forall (scope :: Scope). RuleData scope -> RuleCmds scope
ruleCommands = RuleCmds userOrSystem
cmds
                  , staticDependencies :: forall (scope :: Scope). RuleData scope -> [Dependency]
staticDependencies = [Dependency]
staticDeps
                  , results :: forall (scope :: Scope). RuleData scope -> NonEmpty Location
results = NonEmpty Location
reslts
                  }
                , RuleId
rId
                , [RuleId]
_staticRuleDepIds
                ) =
                  Int -> (RuleData userOrSystem, RuleId, [RuleId])
ruleFromVertex Int
ruleVertex
              mbDyn :: Maybe ([Dependency], ByteString)
mbDyn = RuleId
-> Map RuleId ([Dependency], ByteString)
-> Maybe ([Dependency], ByteString)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RuleId
rId Map RuleId ([Dependency], ByteString)
dynDepsEdges
              allDeps :: [Dependency]
allDeps = [Dependency]
staticDeps [Dependency] -> [Dependency] -> [Dependency]
forall a. [a] -> [a] -> [a]
++ [Dependency] -> Maybe [Dependency] -> [Dependency]
forall a. a -> Maybe a -> a
fromMaybe [] (([Dependency], ByteString) -> [Dependency]
forall a b. (a, b) -> a
fst (([Dependency], ByteString) -> [Dependency])
-> Maybe ([Dependency], ByteString) -> Maybe [Dependency]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ([Dependency], ByteString)
mbDyn)
          -- Check that the dependencies the rule expects are indeed present.
          resolvedDeps <- (Dependency -> IO Location) -> [Dependency] -> IO [Location]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Verbosity
-> RuleId
-> Map RuleId (RuleData userOrSystem)
-> Dependency
-> IO Location
forall (scope :: Scope).
Verbosity
-> RuleId
-> Map RuleId (RuleData scope)
-> Dependency
-> IO Location
resolveDependency Verbosity
verbosity RuleId
rId Map RuleId (RuleData userOrSystem)
allRules) [Dependency]
allDeps
          missingRuleDeps <- filterM (missingDep mbWorkDir) resolvedDeps
          case NE.nonEmpty missingRuleDeps of
            Just NonEmpty Location
missingDeps ->
              RulesException -> IO ()
errorOut (RulesException -> IO ()) -> RulesException -> IO ()
forall a b. (a -> b) -> a -> b
$ RuleBinary -> NonEmpty Location -> RulesException
CantFindSourceForRuleDependencies (RuleData userOrSystem -> RuleBinary
toRuleBinary RuleData userOrSystem
r) NonEmpty Location
missingDeps
            -- Dependencies OK: run the associated action.
            Maybe (NonEmpty Location)
Nothing -> do
              let execCmd :: RuleExecCmd userOrSystem
execCmd = SScope userOrSystem
-> RuleCmds userOrSystem
-> Maybe ByteString
-> RuleExecCmd userOrSystem
forall (scope :: Scope).
SScope scope
-> RuleCmds scope -> Maybe ByteString -> RuleExecCmd scope
ruleExecCmd SScope userOrSystem
scope RuleCmds userOrSystem
cmds (([Dependency], ByteString) -> ByteString
forall a b. (a, b) -> b
snd (([Dependency], ByteString) -> ByteString)
-> Maybe ([Dependency], ByteString) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ([Dependency], ByteString)
mbDyn)
              RuleId -> RuleExecCmd userOrSystem -> IO ()
runCmdData RuleId
rId RuleExecCmd userOrSystem
execCmd
              -- Throw an error if running the action did not result in
              -- the generation of outputs that we expected it to.
              missingRuleResults <- (Location -> IO Bool) -> [Location] -> IO [Location]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Maybe (SymbolicPath CWD ('Dir Pkg)) -> Location -> IO Bool
missingDep Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir) ([Location] -> IO [Location]) -> [Location] -> IO [Location]
forall a b. (a -> b) -> a -> b
$ NonEmpty Location -> [Location]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Location
reslts
              for_ (NE.nonEmpty missingRuleResults) $ \NonEmpty Location
missingResults ->
                RulesException -> IO ()
errorOut (RulesException -> IO ()) -> RulesException -> IO ()
forall a b. (a -> b) -> a -> b
$ RuleBinary -> NonEmpty Location -> RulesException
MissingRuleOutputs (RuleData userOrSystem -> RuleBinary
toRuleBinary RuleData userOrSystem
r) NonEmpty Location
missingResults
              return ()
  where
    toRuleBinary :: RuleData userOrSystem -> RuleBinary
    toRuleBinary :: RuleData userOrSystem -> RuleBinary
toRuleBinary = case SScope userOrSystem
scope of
      SScope userOrSystem
SUser -> RuleData userOrSystem -> RuleBinary
Rule -> RuleBinary
ruleBinary
      SScope userOrSystem
SSystem -> RuleData userOrSystem -> RuleData userOrSystem
RuleData userOrSystem -> RuleBinary
forall a. a -> a
id
    clbi :: ComponentLocalBuildInfo
clbi = TargetInfo -> ComponentLocalBuildInfo
targetCLBI TargetInfo
tgtInfo
    mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi
    compAutogenDir :: SymbolicPath Pkg ('Dir Source)
compAutogenDir = LocalBuildInfo
-> ComponentLocalBuildInfo -> SymbolicPath Pkg ('Dir Source)
autogenComponentModulesDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
    errorOut :: RulesException -> IO ()
errorOut RulesException
e =
      Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ()) -> CabalException -> IO ()
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
e

directRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId
directRuleDependencyMaybe :: Dependency -> Maybe RuleId
directRuleDependencyMaybe (RuleDependency RuleOutput
dep) = RuleId -> Maybe RuleId
forall a. a -> Maybe a
Just (RuleId -> Maybe RuleId) -> RuleId -> Maybe RuleId
forall a b. (a -> b) -> a -> b
$ RuleOutput -> RuleId
outputOfRule RuleOutput
dep
directRuleDependencyMaybe (FileDependency{}) = Maybe RuleId
forall a. Maybe a
Nothing

resolveDependency :: Verbosity -> RuleId -> Map RuleId (RuleData scope) -> Rule.Dependency -> IO Location
resolveDependency :: forall (scope :: Scope).
Verbosity
-> RuleId
-> Map RuleId (RuleData scope)
-> Dependency
-> IO Location
resolveDependency Verbosity
verbosity RuleId
rId Map RuleId (RuleData scope)
allRules = \case
  FileDependency Location
l -> Location -> IO Location
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Location
l
  RuleDependency (RuleOutput{outputOfRule :: RuleOutput -> RuleId
outputOfRule = RuleId
depId, outputIndex :: RuleOutput -> Word
outputIndex = Word
i}) ->
    case RuleId -> Map RuleId (RuleData scope) -> Maybe (RuleData scope)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RuleId
depId Map RuleId (RuleData scope)
allRules of
      Maybe (RuleData scope)
Nothing ->
        String -> IO Location
forall a. HasCallStack => String -> a
error (String -> IO Location) -> String -> IO Location
forall a b. (a -> b) -> a -> b
$
          [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
            [ String
"Internal error: missing rule dependency."
            , String
"Rule: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RuleId -> String
forall a. Show a => a -> String
show RuleId
rId
            , String
"Dependency: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RuleId -> String
forall a. Show a => a -> String
show RuleId
depId
            ]
      Just (Rule{results :: forall (scope :: Scope). RuleData scope -> NonEmpty Location
results = NonEmpty Location
os}) ->
        let j :: Int
            j :: Int
j = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i
         in case [Location] -> Maybe Location
forall a. [a] -> Maybe a
listToMaybe ([Location] -> Maybe Location) -> [Location] -> Maybe Location
forall a b. (a -> b) -> a -> b
$ Int -> [Location] -> [Location]
forall a. Int -> [a] -> [a]
drop Int
j ([Location] -> [Location]) -> [Location] -> [Location]
forall a b. (a -> b) -> a -> b
$ NonEmpty Location -> [Location]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Location
os of
              Just Location
o
                | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 ->
                    Location -> IO Location
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Location
o
              Maybe Location
_ ->
                Verbosity -> CabalException -> IO Location
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO Location) -> CabalException -> IO Location
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 -> RuleId -> NonEmpty Location -> Word -> RulesException
InvalidRuleOutputIndex RuleId
rId RuleId
depId NonEmpty Location
os Word
i

-- | Does the rule output the given location?
ruleOutputsLocation :: RuleData scope -> Location -> Bool
ruleOutputsLocation :: forall (scope :: Scope). RuleData scope -> Location -> Bool
ruleOutputsLocation (Rule{results :: forall (scope :: Scope). RuleData scope -> NonEmpty Location
results = NonEmpty Location
rs}) Location
fp =
  (Location -> Bool) -> NonEmpty Location -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Location
out -> Location -> Location
normaliseLocation Location
out Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
== Location -> Location
normaliseLocation Location
fp) NonEmpty Location
rs

normaliseLocation :: Location -> Location
normaliseLocation :: Location -> Location
normaliseLocation (Location SymbolicPath Pkg ('Dir baseDir)
base RelativePath baseDir 'File
rel) =
  SymbolicPath Pkg ('Dir baseDir)
-> RelativePath baseDir 'File -> Location
forall baseDir.
SymbolicPath Pkg ('Dir baseDir)
-> RelativePath baseDir 'File -> Location
Location (SymbolicPath Pkg ('Dir baseDir) -> SymbolicPath Pkg ('Dir baseDir)
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to
-> SymbolicPathX allowAbsolute from to
normaliseSymbolicPath SymbolicPath Pkg ('Dir baseDir)
base) (RelativePath baseDir 'File -> RelativePath baseDir 'File
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to
-> SymbolicPathX allowAbsolute from to
normaliseSymbolicPath RelativePath baseDir 'File
rel)

-- | Is the file we depend on missing?
missingDep :: Maybe (SymbolicPath CWD (Dir Pkg)) -> Location -> IO Bool
missingDep :: Maybe (SymbolicPath CWD ('Dir Pkg)) -> Location -> IO Bool
missingDep Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir Location
loc = Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
doesFileExist String
fp
  where
    fp :: String
fp = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX 'AllowAbsolute Pkg 'File -> String
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> String
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (Location -> SymbolicPathX 'AllowAbsolute Pkg 'File
location Location
loc)

--------------------------------------------------------------------------------
-- 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 :: HookedBuildInfo -> Set ComponentName
hookedBuildInfoComponents (Maybe BuildInfo
mb_mainlib, [(UnqualComponentName, BuildInfo)]
exes) =
  [ComponentName] -> Set ComponentName
forall a. Ord a => [a] -> Set a
Set.fromList ([ComponentName] -> Set ComponentName)
-> [ComponentName] -> Set ComponentName
forall a b. (a -> b) -> a -> b
$
    (case Maybe BuildInfo
mb_mainlib of Maybe BuildInfo
Nothing -> [ComponentName] -> [ComponentName]
forall a. a -> a
id; Just{} -> (LibraryName -> ComponentName
CLibName LibraryName
LMainLibName ComponentName -> [ComponentName] -> [ComponentName]
forall a. a -> [a] -> [a]
:))
      [UnqualComponentName -> ComponentName
CExeName UnqualComponentName
exe_nm | (UnqualComponentName
exe_nm, BuildInfo
_) <- [(UnqualComponentName, BuildInfo)]
exes]

hookedBuildInfoComponentDiff_maybe :: HookedBuildInfo -> ComponentName -> Maybe (IO ComponentDiff)
hookedBuildInfoComponentDiff_maybe :: HookedBuildInfo -> ComponentName -> Maybe (IO ComponentDiff)
hookedBuildInfoComponentDiff_maybe (Maybe BuildInfo
mb_mainlib, [(UnqualComponentName, BuildInfo)]
exes) ComponentName
comp_nm =
  case ComponentName
comp_nm of
    CLibName LibraryName
lib_nm ->
      case LibraryName
lib_nm of
        LibraryName
LMainLibName -> ComponentDiff -> IO ComponentDiff
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentDiff -> IO ComponentDiff)
-> (BuildInfo -> ComponentDiff) -> BuildInfo -> IO ComponentDiff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Component -> ComponentDiff
ComponentDiff (Component -> ComponentDiff)
-> (BuildInfo -> Component) -> BuildInfo -> ComponentDiff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> Component
CLib (Library -> Component)
-> (BuildInfo -> Library) -> BuildInfo -> Component
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildInfo -> Library
buildInfoLibraryDiff (BuildInfo -> IO ComponentDiff)
-> Maybe BuildInfo -> Maybe (IO ComponentDiff)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe BuildInfo
mb_mainlib
        LSubLibName{} -> Maybe (IO ComponentDiff)
forall a. Maybe a
Nothing
    CExeName UnqualComponentName
exe_nm ->
      let mb_exe :: Maybe BuildInfo
mb_exe = UnqualComponentName
-> [(UnqualComponentName, BuildInfo)] -> Maybe BuildInfo
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup UnqualComponentName
exe_nm [(UnqualComponentName, BuildInfo)]
exes
       in ComponentDiff -> IO ComponentDiff
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentDiff -> IO ComponentDiff)
-> (BuildInfo -> ComponentDiff) -> BuildInfo -> IO ComponentDiff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Component -> ComponentDiff
ComponentDiff (Component -> ComponentDiff)
-> (BuildInfo -> Component) -> BuildInfo -> ComponentDiff
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Executable -> Component
CExe (Executable -> Component)
-> (BuildInfo -> Executable) -> BuildInfo -> Component
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildInfo -> Executable
buildInfoExecutableDiff (BuildInfo -> IO ComponentDiff)
-> Maybe BuildInfo -> Maybe (IO ComponentDiff)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe BuildInfo
mb_exe
    CFLibName{} -> Maybe (IO ComponentDiff)
forall a. Maybe a
Nothing
    CTestName{} -> Maybe (IO ComponentDiff)
forall a. Maybe a
Nothing
    CBenchName{} -> Maybe (IO ComponentDiff)
forall a. Maybe a
Nothing

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

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

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

deriving newtype instance Binary ComponentDiff
deriving newtype instance Structured ComponentDiff

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

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