module Hix.Managed.Bump.Optimize where

import Exon (exon)

import Hix.Class.Map (nMap)
import Hix.Data.Monad (M)
import qualified Hix.Data.Overrides
import Hix.Data.VersionBounds (fromLower)
import Hix.Managed.Build (processQuery)
import Hix.Managed.Bump.Candidates (candidatesBump)
import qualified Hix.Managed.Cabal.Data.SolverState
import Hix.Managed.Cabal.Data.SolverState (SolverFlags (SolverFlags), solverState)
import Hix.Managed.Constraints (fromVersions, preferInstalled, preferVersions)
import qualified Hix.Managed.Data.BuildConfig
import Hix.Managed.Data.BuildConfig (BuildConfig)
import Hix.Managed.Data.Bump (Bump (..))
import Hix.Managed.Data.Constraints (EnvConstraints)
import qualified Hix.Managed.Data.EnvContext
import Hix.Managed.Data.EnvContext (EnvDeps)
import Hix.Managed.Data.Initial (Initial (Initial))
import Hix.Managed.Data.Mutable (MutableDep)
import qualified Hix.Managed.Data.MutableId
import Hix.Managed.Data.MutableId (MutableId (MutableId))
import Hix.Managed.Data.Mutation (DepMutation (..))
import qualified Hix.Managed.Data.MutationState
import Hix.Managed.Data.MutationState (MutationState)
import qualified Hix.Managed.Data.ProjectContext
import Hix.Managed.Data.ProjectContext (ProjectContext)
import Hix.Managed.Data.ProjectResult (ProjectResult)
import Hix.Managed.Data.Query (Query (Query))
import qualified Hix.Managed.Data.StageContext
import Hix.Managed.Data.StageContext (StageContext (StageContext))
import Hix.Managed.Data.StageResult (StageResult, StageSummary (StageNoAction, StageReport))
import Hix.Managed.Data.StageState (BuildStatus, BuildSuccess)
import Hix.Managed.Flow (Flow, execStage, execStatelessStage)
import qualified Hix.Managed.Handlers.Build
import Hix.Managed.Handlers.Build (BuildHandlers)
import Hix.Managed.Handlers.Cabal (CabalHandlers, installedVersions)
import Hix.Managed.Handlers.Mutation.Bump (handlersBump)
import Hix.Managed.Process (processProject)
import Hix.Managed.Report (describeIterations)
import Hix.Managed.StageResult (stageResult)

-- | Solver params for Bump consist of, in decreasing order of precedence:
--
-- - User-specified bounds (added by the constructor 'solverState').
--
-- - The existing overrides from previous runs, used as preferred versions.
--   This ensures that the solver selects the same versions as in the last run while still allowing newer versions for
--   transitive dependencies that are later in the candidate list.
--
-- - Installed versions from the package db, used as lower bounds.
--
-- - The preference for using the installed version for mutable deps, which is a fallback for packages without overrides
--   (since their chosen versions are installed).
bumpSolverParams ::
  EnvDeps ->
  CabalHandlers ->
  Initial MutationState ->
  EnvConstraints
bumpSolverParams :: EnvDeps -> CabalHandlers -> Initial MutationState -> EnvConstraints
bumpSolverParams EnvDeps
deps CabalHandlers
cabal (Initial MutationState
state) =
  Versions -> EnvConstraints
preferVersions ((Override -> Version) -> Overrides -> Versions
forall map1 k v1 sort1 map2 v2 sort2.
(NMap map1 k v1 sort1, NMap map2 k v2 sort2) =>
(v1 -> v2) -> map1 -> map2
nMap (.version) MutationState
state.overrides) EnvConstraints -> EnvConstraints -> EnvConstraints
forall a. Semigroup a => a -> a -> a
<>
  (Version -> VersionBounds) -> MutableVersions -> EnvConstraints
fromVersions Version -> VersionBounds
fromLower (CabalHandlers -> Set MutableDep -> MutableVersions
installedVersions CabalHandlers
cabal EnvDeps
deps.mutable) EnvConstraints -> EnvConstraints -> EnvConstraints
forall a. Semigroup a => a -> a -> a
<>
  Set MutableDep -> EnvConstraints
preferInstalled EnvDeps
deps.mutable

success :: Map MutableDep BuildSuccess -> Natural -> Text
success :: Map MutableDep BuildSuccess -> Natural -> Text
success Map MutableDep BuildSuccess
_ Natural
iterations =
  [exon|Found working latest versions for all deps after #{iter}.|]
  where
    iter :: Text
iter = Natural -> Text
describeIterations Natural
iterations

failure :: Natural -> Text
failure :: Natural -> Text
failure Natural
iterations =
  [exon|Couldn't find working latest versions for some deps after #{describeIterations iterations}.|]

bumpBuild ::
  BuildHandlers ->
  BuildConfig ->
  StageContext ->
  M StageResult
bumpBuild :: BuildHandlers -> BuildConfig -> StageContext -> M StageResult
bumpBuild BuildHandlers
handlers BuildConfig
conf stage :: StageContext
stage@StageContext {EnvContext
env :: EnvContext
$sel:env:StageContext :: StageContext -> EnvContext
env, EnvBuilder
builder :: EnvBuilder
$sel:builder:StageContext :: StageContext -> EnvBuilder
builder, Initial MutationState
state :: Initial MutationState
$sel:state:StageContext :: StageContext -> Initial MutationState
state} = do
  StageState Bump SolverState
result <- (QueryDep -> M (Maybe (DepMutation Bump)))
-> MutationHandlers Bump SolverState
-> BuildConfig
-> StageContext
-> SolverState
-> M (StageState Bump SolverState)
forall a s.
Pretty a =>
(QueryDep -> M (Maybe (DepMutation a)))
-> MutationHandlers a s
-> BuildConfig
-> StageContext
-> s
-> M (StageState a s)
processQuery (BuildHandlers -> QueryDep -> M (Maybe (DepMutation Bump))
candidatesBump BuildHandlers
handlers) MutationHandlers Bump SolverState
handlersBump BuildConfig
conf StageContext
stage SolverState
ext
  pure ((Map MutableDep BuildSuccess -> Natural -> Text)
-> (Natural -> Text) -> StageState Bump SolverState -> StageResult
forall a s.
Pretty a =>
(Map MutableDep BuildSuccess -> Natural -> Text)
-> (Natural -> Text) -> StageState a s -> StageResult
stageResult Map MutableDep BuildSuccess -> Natural -> Text
success Natural -> Text
failure StageState Bump SolverState
result)
  where
    ext :: SolverState
ext = Ranges -> EnvDeps -> EnvConstraints -> SolverFlags -> SolverState
solverState EnvContext
env.solverBounds EnvContext
env.deps (EnvDeps -> CabalHandlers -> Initial MutationState -> EnvConstraints
bumpSolverParams EnvContext
env.deps EnvBuilder
builder.cabal Initial MutationState
state) SolverFlags
flags
    flags :: SolverFlags
flags = SolverFlags {$sel:allowNewer:SolverFlags :: Bool
allowNewer = Bool
True}

bumpBuildStage ::
  BuildHandlers ->
  BuildConfig ->
  Flow BuildStatus
bumpBuildStage :: BuildHandlers -> BuildConfig -> Flow BuildStatus
bumpBuildStage BuildHandlers
handlers BuildConfig
conf =
  Text -> (StageContext -> M StageResult) -> Flow BuildStatus
execStage Text
"bump" (BuildHandlers -> BuildConfig -> StageContext -> M StageResult
bumpBuild BuildHandlers
handlers BuildConfig
conf)

bumpReportStage ::
  BuildHandlers ->
  Flow BuildStatus
bumpReportStage :: BuildHandlers -> Flow BuildStatus
bumpReportStage BuildHandlers
handlers =
  Text -> (StageContext -> M StageSummary) -> Flow BuildStatus
execStatelessStage Text
"bump-report" \ StageContext {$sel:query:StageContext :: StageContext -> Query
query = Query NonEmpty QueryDep
query} ->
    Maybe (NonEmpty MutableId) -> StageSummary
toSummary (Maybe (NonEmpty MutableId) -> StageSummary)
-> ([Maybe (DepMutation Bump)] -> Maybe (NonEmpty MutableId))
-> [Maybe (DepMutation Bump)]
-> StageSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (DepMutation Bump)] -> Maybe (NonEmpty MutableId)
toCandidates ([Maybe (DepMutation Bump)] -> StageSummary)
-> M [Maybe (DepMutation Bump)] -> M StageSummary
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (QueryDep -> M (Maybe (DepMutation Bump)))
-> [QueryDep] -> M [Maybe (DepMutation Bump)]
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 (BuildHandlers -> QueryDep -> M (Maybe (DepMutation Bump))
candidatesBump BuildHandlers
handlers) (NonEmpty QueryDep -> [QueryDep]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty QueryDep
query)
  where
    toSummary :: Maybe (NonEmpty MutableId) -> StageSummary
toSummary = \case
      Just NonEmpty MutableId
cs -> Text -> NonEmpty MutableId -> StageSummary
StageReport Text
"Found new versions:" NonEmpty MutableId
cs
      Maybe (NonEmpty MutableId)
Nothing -> Maybe Text -> StageSummary
StageNoAction (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"All dependencies are up to date.")

    toCandidates :: [Maybe (DepMutation Bump)] -> Maybe (NonEmpty MutableId)
toCandidates = [MutableId] -> Maybe (NonEmpty MutableId)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([MutableId] -> Maybe (NonEmpty MutableId))
-> ([Maybe (DepMutation Bump)] -> [MutableId])
-> [Maybe (DepMutation Bump)]
-> Maybe (NonEmpty MutableId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DepMutation Bump -> MutableId)
-> [DepMutation Bump] -> [MutableId]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DepMutation Bump -> MutableId
toCandidate ([DepMutation Bump] -> [MutableId])
-> ([Maybe (DepMutation Bump)] -> [DepMutation Bump])
-> [Maybe (DepMutation Bump)]
-> [MutableId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (DepMutation Bump)] -> [DepMutation Bump]
forall a. [Maybe a] -> [a]
catMaybes

    toCandidate :: DepMutation Bump -> MutableId
toCandidate DepMutation {$sel:package:DepMutation :: forall a. DepMutation a -> MutableDep
package = MutableDep
name, $sel:mutation:DepMutation :: forall a. DepMutation a -> a
mutation = Bump {Version
version :: Version
$sel:version:Bump :: Bump -> Version
version}} =
      MutableId {Version
MutableDep
name :: MutableDep
version :: Version
$sel:name:MutableId :: MutableDep
$sel:version:MutableId :: Version
..}

bumpStages ::
  BuildHandlers ->
  BuildConfig ->
  Flow BuildStatus
bumpStages :: BuildHandlers -> BuildConfig -> Flow BuildStatus
bumpStages BuildHandlers
handlers BuildConfig
conf
  | BuildConfig
conf.lookup
  = BuildHandlers -> Flow BuildStatus
bumpReportStage BuildHandlers
handlers
  | Bool
otherwise
  = BuildHandlers -> BuildConfig -> Flow BuildStatus
bumpBuildStage BuildHandlers
handlers BuildConfig
conf

bumpOptimizeMain ::
  BuildHandlers ->
  ProjectContext ->
  M ProjectResult
bumpOptimizeMain :: BuildHandlers -> ProjectContext -> M ProjectResult
bumpOptimizeMain BuildHandlers
handlers ProjectContext
project =
  BuildHandlers -> ProjectContext -> Flow () -> M ProjectResult
processProject BuildHandlers
handlers ProjectContext
project (Flow BuildStatus -> Flow ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (BuildHandlers -> BuildConfig -> Flow BuildStatus
bumpStages BuildHandlers
handlers ProjectContext
project.build))