module Hix.Managed.Handlers.Mutation.Lower where

import Control.Monad (foldM)
import Data.Foldable.Extra (firstJustM)
import Data.Generics.Labels ()
import Exon (exon)

import Hix.Data.Monad (M)
import Hix.Data.PackageId (PackageId)
import qualified Hix.Data.Version
import Hix.Data.Version (Major (Major))
import Hix.Data.VersionBounds (withLower)
import qualified Hix.Log as Log
import Hix.Managed.Build.Mutation (buildCandidate)
import Hix.Managed.Cabal.Data.SolverState (SolverState)
import qualified Hix.Managed.Data.BuildConfig
import Hix.Managed.Data.BuildConfig (BuildConfig)
import Hix.Managed.Data.Constraints (MutationConstraints)
import qualified Hix.Managed.Data.Lower
import Hix.Managed.Data.Lower (Lower (Lower))
import Hix.Managed.Data.MutableId (MutableId)
import qualified Hix.Managed.Data.Mutation
import Hix.Managed.Data.Mutation (BuildMutation, DepMutation (DepMutation), MutationResult (MutationSuccess))
import Hix.Managed.Data.MutationState (MutationState)
import qualified Hix.Managed.Handlers.Mutation
import Hix.Managed.Handlers.Mutation (MutationHandlers (MutationHandlers))
import qualified Hix.Managed.Lower.Data.LowerMode
import Hix.Managed.Lower.Data.LowerMode (LowerMode)
import Hix.Pretty (showP)

-- TODO would be nice if the deps that succeed as transitive deps would have their candidates trimmed so that it
-- immediately returns success when the version is encountered that succeeded most recently that way.
--
-- TODO Can we get a sensible value for @changed@?
processMutationLower ::
  BuildConfig ->
  LowerMode ->
  (Bool -> MutableId -> PackageId -> MutationConstraints -> MutationConstraints) ->
  SolverState ->
  DepMutation Lower ->
  (BuildMutation -> M (Maybe (MutationState, Set PackageId))) ->
  M (MutationResult SolverState)
processMutationLower :: BuildConfig
-> LowerMode
-> (Bool
    -> MutableId
    -> PackageId
    -> MutationConstraints
    -> MutationConstraints)
-> SolverState
-> DepMutation Lower
-> (BuildMutation -> M (Maybe (MutationState, Set PackageId)))
-> M (MutationResult SolverState)
processMutationLower BuildConfig
conf LowerMode
mode Bool
-> MutableId
-> PackageId
-> MutationConstraints
-> MutationConstraints
update SolverState
solver DepMutation {MutableDep
package :: MutableDep
package :: forall a. DepMutation a -> MutableDep
package, Bool
retract :: Bool
retract :: forall a. DepMutation a -> Bool
retract, mutation :: forall a. DepMutation a -> a
mutation = Lower {NonEmpty Major
majors :: NonEmpty Major
majors :: Lower -> NonEmpty Major
majors}} BuildMutation -> M (Maybe (MutationState, Set PackageId))
build = do
  ((Either Natural Natural,
  Maybe (MutableId, SolverState, MutationState, Set PackageId))
 -> Major
 -> M (Either Natural Natural,
       Maybe (MutableId, SolverState, MutationState, Set PackageId)))
-> (Either Natural Natural,
    Maybe (MutableId, SolverState, MutationState, Set PackageId))
-> NonEmpty Major
-> M (Either Natural Natural,
      Maybe (MutableId, SolverState, MutationState, Set PackageId))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Either Natural Natural,
 Maybe (MutableId, SolverState, MutationState, Set PackageId))
-> Major
-> M (Either Natural Natural,
      Maybe (MutableId, SolverState, MutationState, Set PackageId))
buildMajor (Natural -> Either Natural Natural
forall a b. b -> Either a b
Right Natural
0, Maybe (MutableId, SolverState, MutationState, Set PackageId)
forall a. Maybe a
Nothing) NonEmpty Major
majors M (Either Natural Natural,
   Maybe (MutableId, SolverState, MutationState, Set PackageId))
-> ((Either Natural Natural,
     Maybe (MutableId, SolverState, MutationState, Set PackageId))
    -> MutationResult SolverState)
-> M (MutationResult SolverState)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    (Either Natural Natural
_, Just (MutableId
candidate, SolverState
ext, MutationState
state, Set PackageId
revisions)) ->
      MutationSuccess {MutableId
candidate :: MutableId
candidate :: MutableId
candidate, changed :: Bool
changed = Bool
True, MutationState
state :: MutationState
state :: MutationState
state, Set PackageId
revisions :: Set PackageId
revisions :: Set PackageId
revisions, SolverState
ext :: SolverState
ext :: SolverState
ext}
    (Either Natural Natural
_, Maybe (MutableId, SolverState, MutationState, Set PackageId)
Nothing) ->
      LowerMode
mode.noSuccess
  where
    -- | We skip all remaining majors when the number of failed majors exceeds the configured limit.
    -- There are different values for failures before the first and after the last success.
    -- This avoid building the project tens of times for versions that cannot succeed.
    --
    -- We also skip all remaining majors when @firstSuccess@ is set, after a major succeeded.
    buildMajor :: (Either Natural Natural,
 Maybe (MutableId, SolverState, MutationState, Set PackageId))
-> Major
-> M (Either Natural Natural,
      Maybe (MutableId, SolverState, MutationState, Set PackageId))
buildMajor (Either Natural Natural
failed, Maybe (MutableId, SolverState, MutationState, Set PackageId)
prev) Major {Version
prefix :: Version
prefix :: Major -> Version
prefix, NonEmpty Version
versions :: NonEmpty Version
versions :: Major -> NonEmpty Version
versions}
      | Right Natural
n <- Either Natural Natural
failed
      , Natural
n Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> BuildConfig
conf.maxFailedPre
      = (Either Natural Natural,
 Maybe (MutableId, SolverState, MutationState, Set PackageId))
-> M (Either Natural Natural,
      Maybe (MutableId, SolverState, MutationState, Set PackageId))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Natural Natural
failed, Maybe (MutableId, SolverState, MutationState, Set PackageId)
prev)

      | Left Natural
n <- Either Natural Natural
failed
      , Natural
n Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> BuildConfig
conf.maxFailedPost
      = (Either Natural Natural,
 Maybe (MutableId, SolverState, MutationState, Set PackageId))
-> M (Either Natural Natural,
      Maybe (MutableId, SolverState, MutationState, Set PackageId))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Natural Natural
failed, Maybe (MutableId, SolverState, MutationState, Set PackageId)
prev)

      | LowerMode
mode.firstSuccess
      , Just (MutableId, SolverState, MutationState, Set PackageId)
_ <- Maybe (MutableId, SolverState, MutationState, Set PackageId)
prev
      = (Either Natural Natural,
 Maybe (MutableId, SolverState, MutationState, Set PackageId))
-> M (Either Natural Natural,
      Maybe (MutableId, SolverState, MutationState, Set PackageId))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Natural Natural
failed, Maybe (MutableId, SolverState, MutationState, Set PackageId)
prev)

      | Bool
otherwise
      = do
        Text -> M ()
Log.debug [exon|Building major #{showP prefix} for '##{package}'|]
        (Version
 -> M (Maybe
         (MutableId, SolverState, MutationState, Set PackageId)))
-> NonEmpty Version
-> M (Maybe (MutableId, SolverState, MutationState, Set PackageId))
forall (f :: * -> *) (m :: * -> *) a b.
(Foldable f, Monad m) =>
(a -> m (Maybe b)) -> f a -> m (Maybe b)
firstJustM Version
-> M (Maybe (MutableId, SolverState, MutationState, Set PackageId))
builder NonEmpty Version
versions M (Maybe (MutableId, SolverState, MutationState, Set PackageId))
-> (Maybe (MutableId, SolverState, MutationState, Set PackageId)
    -> (Either Natural Natural,
        Maybe (MutableId, SolverState, MutationState, Set PackageId)))
-> M (Either Natural Natural,
      Maybe (MutableId, SolverState, MutationState, Set PackageId))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          Just (MutableId, SolverState, MutationState, Set PackageId)
result -> (Natural -> Either Natural Natural
forall a b. a -> Either a b
Left Natural
0, (MutableId, SolverState, MutationState, Set PackageId)
-> Maybe (MutableId, SolverState, MutationState, Set PackageId)
forall a. a -> Maybe a
Just (MutableId, SolverState, MutationState, Set PackageId)
result)
          Maybe (MutableId, SolverState, MutationState, Set PackageId)
Nothing -> ((Natural -> Natural)
-> (Natural -> Natural)
-> Either Natural Natural
-> Either Natural Natural
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1) (Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1) Either Natural Natural
failed, Maybe (MutableId, SolverState, MutationState, Set PackageId)
prev)

    builder :: Version
-> M (Maybe (MutableId, SolverState, MutationState, Set PackageId))
builder = (BuildMutation -> M (Maybe (MutationState, Set PackageId)))
-> (Version -> VersionBounds -> VersionBounds)
-> (MutableId
    -> PackageId -> MutationConstraints -> MutationConstraints)
-> SolverState
-> MutableDep
-> Version
-> M (Maybe (MutableId, SolverState, MutationState, Set PackageId))
buildCandidate BuildMutation -> M (Maybe (MutationState, Set PackageId))
build Version -> VersionBounds -> VersionBounds
withLower (Bool
-> MutableId
-> PackageId
-> MutationConstraints
-> MutationConstraints
update Bool
retract) SolverState
solver MutableDep
package

handlersLower ::
  BuildConfig ->
  LowerMode ->
  (Bool -> MutableId -> PackageId -> MutationConstraints -> MutationConstraints) ->
  MutationHandlers Lower SolverState
handlersLower :: BuildConfig
-> LowerMode
-> (Bool
    -> MutableId
    -> PackageId
    -> MutationConstraints
    -> MutationConstraints)
-> MutationHandlers Lower SolverState
handlersLower BuildConfig
conf LowerMode
mode Bool
-> MutableId
-> PackageId
-> MutationConstraints
-> MutationConstraints
updatePackageParams =
  MutationHandlers {process :: SolverState
-> DepMutation Lower
-> (BuildMutation -> M (Maybe (MutationState, Set PackageId)))
-> M (MutationResult SolverState)
process = BuildConfig
-> LowerMode
-> (Bool
    -> MutableId
    -> PackageId
    -> MutationConstraints
    -> MutationConstraints)
-> SolverState
-> DepMutation Lower
-> (BuildMutation -> M (Maybe (MutationState, Set PackageId)))
-> M (MutationResult SolverState)
processMutationLower BuildConfig
conf LowerMode
mode Bool
-> MutableId
-> PackageId
-> MutationConstraints
-> MutationConstraints
updatePackageParams}