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)) ->
  M (MutationResult SolverState)
processMutationLower :: BuildConfig
-> LowerMode
-> (Bool
    -> MutableId
    -> PackageId
    -> MutationConstraints
    -> MutationConstraints)
-> SolverState
-> DepMutation Lower
-> (BuildMutation -> M (Maybe MutationState))
-> M (MutationResult SolverState)
processMutationLower BuildConfig
conf LowerMode
mode Bool
-> MutableId
-> PackageId
-> MutationConstraints
-> MutationConstraints
update SolverState
solver DepMutation {MutableDep
package :: MutableDep
$sel:package:DepMutation :: forall a. DepMutation a -> MutableDep
package, Bool
retract :: Bool
$sel:retract:DepMutation :: forall a. DepMutation a -> Bool
retract, $sel:mutation:DepMutation :: forall a. DepMutation a -> a
mutation = Lower {NonEmpty Major
majors :: NonEmpty Major
$sel:majors:Lower :: Lower -> NonEmpty Major
majors}} BuildMutation -> M (Maybe MutationState)
build = do
  ((Either Natural Natural,
  Maybe (MutableId, SolverState, MutationState))
 -> Major
 -> M (Either Natural Natural,
       Maybe (MutableId, SolverState, MutationState)))
-> (Either Natural Natural,
    Maybe (MutableId, SolverState, MutationState))
-> NonEmpty Major
-> M (Either Natural Natural,
      Maybe (MutableId, SolverState, MutationState))
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))
-> Major
-> M (Either Natural Natural,
      Maybe (MutableId, SolverState, MutationState))
buildMajor (Natural -> Either Natural Natural
forall a b. b -> Either a b
Right Natural
0, Maybe (MutableId, SolverState, MutationState)
forall a. Maybe a
Nothing) NonEmpty Major
majors M (Either Natural Natural,
   Maybe (MutableId, SolverState, MutationState))
-> ((Either Natural Natural,
     Maybe (MutableId, SolverState, MutationState))
    -> 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)) ->
      MutationSuccess {MutableId
candidate :: MutableId
$sel:candidate:MutationSuccess :: MutableId
candidate, $sel:changed:MutationSuccess :: Bool
changed = Bool
True, MutationState
state :: MutationState
$sel:state:MutationSuccess :: MutationState
state, SolverState
ext :: SolverState
$sel:ext:MutationSuccess :: SolverState
ext}
    (Either Natural Natural
_, Maybe (MutableId, SolverState, MutationState)
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))
-> Major
-> M (Either Natural Natural,
      Maybe (MutableId, SolverState, MutationState))
buildMajor (Either Natural Natural
failed, Maybe (MutableId, SolverState, MutationState)
prev) Major {Version
prefix :: Version
$sel:prefix:Major :: Major -> Version
prefix, NonEmpty Version
versions :: NonEmpty Version
$sel:versions:Major :: 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))
-> M (Either Natural Natural,
      Maybe (MutableId, SolverState, MutationState))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Natural Natural
failed, Maybe (MutableId, SolverState, MutationState)
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))
-> M (Either Natural Natural,
      Maybe (MutableId, SolverState, MutationState))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Natural Natural
failed, Maybe (MutableId, SolverState, MutationState)
prev)

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

      | Bool
otherwise
      = do
        Text -> M ()
Log.debug [exon|Building major #{showP prefix} for '##{package}'|]
        (Version -> M (Maybe (MutableId, SolverState, MutationState)))
-> NonEmpty Version
-> M (Maybe (MutableId, SolverState, MutationState))
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))
builder NonEmpty Version
versions M (Maybe (MutableId, SolverState, MutationState))
-> (Maybe (MutableId, SolverState, MutationState)
    -> (Either Natural Natural,
        Maybe (MutableId, SolverState, MutationState)))
-> M (Either Natural Natural,
      Maybe (MutableId, SolverState, MutationState))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          Just (MutableId, SolverState, MutationState)
result -> (Natural -> Either Natural Natural
forall a b. a -> Either a b
Left Natural
0, (MutableId, SolverState, MutationState)
-> Maybe (MutableId, SolverState, MutationState)
forall a. a -> Maybe a
Just (MutableId, SolverState, MutationState)
result)
          Maybe (MutableId, SolverState, MutationState)
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)
prev)

    builder :: Version -> M (Maybe (MutableId, SolverState, MutationState))
builder = (BuildMutation -> M (Maybe MutationState))
-> (Version -> VersionBounds -> VersionBounds)
-> (MutableId
    -> PackageId -> MutationConstraints -> MutationConstraints)
-> SolverState
-> MutableDep
-> Version
-> M (Maybe (MutableId, SolverState, MutationState))
buildCandidate BuildMutation -> M (Maybe MutationState)
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 {$sel:process:MutationHandlers :: SolverState
-> DepMutation Lower
-> (BuildMutation -> M (Maybe MutationState))
-> M (MutationResult SolverState)
process = BuildConfig
-> LowerMode
-> (Bool
    -> MutableId
    -> PackageId
    -> MutationConstraints
    -> MutationConstraints)
-> SolverState
-> DepMutation Lower
-> (BuildMutation -> M (Maybe MutationState))
-> M (MutationResult SolverState)
processMutationLower BuildConfig
conf LowerMode
mode Bool
-> MutableId
-> PackageId
-> MutationConstraints
-> MutationConstraints
updatePackageParams}