module Hix.Managed.Lower.Stabilize where

import Exon (exon)

import Hix.Class.Map (nToMaybe, (!!))
import Hix.Data.Monad (M)
import qualified Hix.Data.PackageId
import Hix.Data.PackageId (PackageId (PackageId))
import qualified Hix.Data.VersionBounds
import Hix.Data.VersionBounds (VersionBounds (VersionBounds), fromLower, fromUpper)
import Hix.Managed.Build (processQuery)
import Hix.Managed.Build.Single (buildVersions)
import Hix.Managed.Cabal.Data.SolverState (solverState)
import Hix.Managed.Constraints (fromVersions)
import Hix.Managed.Data.BuildConfig (BuildConfig)
import qualified Hix.Managed.Data.Constraints
import Hix.Managed.Data.Constraints (MutationConstraints (MutationConstraints))
import qualified Hix.Managed.Data.EnvContext
import Hix.Managed.Data.Initial (Initial (Initial))
import Hix.Managed.Data.Mutable (MutableDep, MutableVersions, depName)
import qualified Hix.Managed.Data.MutableId
import Hix.Managed.Data.MutableId (MutableId)
import qualified Hix.Managed.Data.MutationState
import Hix.Managed.Data.MutationState (MutationState (MutationState))
import qualified Hix.Managed.Data.ProjectContext
import Hix.Managed.Data.ProjectContext (ProjectContext)
import Hix.Managed.Data.ProjectResult (ProjectResult)
import qualified Hix.Managed.Data.QueryDep
import qualified Hix.Managed.Data.StageContext
import Hix.Managed.Data.StageContext (StageContext (StageContext))
import Hix.Managed.Data.StageResult (
  StageFailure (FailedPrecondition),
  StageResult,
  StageSummary (StageFailure, StageNoAction),
  )
import Hix.Managed.Data.StageState (BuildStatus (Failure, Success), BuildSuccess)
import Hix.Managed.Flow (Flow, execStatelessStage, runStage_)
import qualified Hix.Managed.Handlers.Build
import Hix.Managed.Handlers.Build (BuildHandlers)
import qualified Hix.Managed.Handlers.Mutation.Lower as Mutation
import Hix.Managed.Lower.Candidates (candidatesStabilize)
import Hix.Managed.Lower.Data.LowerMode (lowerStabilizeMode)
import Hix.Managed.Process (processProject)
import Hix.Managed.Report (describeIterations)
import Hix.Managed.StageResult (stageResult)

-- TODO When some initial versions are missing, e.g. because the user added deps and the project broke at the same time,
-- it is up to luck that the solver chooses working versions.
-- Unlikely that there's a useful heuristic though.
initialVersions ::
  MutableVersions ->
  [PackageId]
initialVersions :: MutableVersions -> [PackageId]
initialVersions MutableVersions
state =
  MutableVersions
-> (MutableDep -> Maybe Version -> Maybe PackageId) -> [PackageId]
forall map k v sort a.
NMap map k v sort =>
map -> (k -> v -> Maybe a) -> [a]
nToMaybe MutableVersions
state \ MutableDep
name -> (Version -> PackageId) -> Maybe Version -> Maybe PackageId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MutableDep -> Version -> PackageId
initVersion MutableDep
name)
  where
    initVersion :: MutableDep -> Version -> PackageId
initVersion MutableDep
name Version
version = PackageId {name :: PackageName
name = MutableDep -> PackageName
depName MutableDep
name, Version
version :: Version
version :: Version
..}

buildLowerInit :: Flow BuildStatus
buildLowerInit :: Flow BuildStatus
buildLowerInit = do
  Text -> (StageContext -> M StageSummary) -> Flow BuildStatus
execStatelessStage Text
"stabilize-initial" \ StageContext {EnvContext
env :: EnvContext
env :: StageContext -> EnvContext
env, MutableVersions
initial :: MutableVersions
initial :: StageContext -> MutableVersions
initial, EnvBuilder
builder :: EnvBuilder
builder :: StageContext -> EnvBuilder
builder} ->
    EnvBuilder
-> EnvContext -> Text -> MutableVersions -> M BuildStatus
buildVersions EnvBuilder
builder EnvContext
env Text
"initial lower bounds" MutableVersions
initial M BuildStatus -> (BuildStatus -> StageSummary) -> M StageSummary
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      BuildStatus
Success -> Maybe Text -> StageSummary
StageNoAction (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Env builds successfully with the initial bounds.")
      BuildStatus
Failure -> StageFailure -> StageSummary
StageFailure (NonEmpty Text -> StageFailure
FailedPrecondition NonEmpty Text
msg)
  where
    msg :: NonEmpty Text
msg =
      [
        Item (NonEmpty Text)
[exon|Cannot stabilize since the build with initial bounds failed.|],
        Item (NonEmpty Text)
"Please run 'lower.init --reset' or fix the build manually."
      ]

lowerStabilizeUpdate :: Bool -> MutableId -> PackageId -> MutationConstraints -> MutationConstraints
lowerStabilizeUpdate :: Bool
-> MutableId
-> PackageId
-> MutationConstraints
-> MutationConstraints
lowerStabilizeUpdate Bool
retract MutableId
candidate PackageId {PackageName
name :: PackageId -> PackageName
name :: PackageName
name, Version
version :: PackageId -> Version
version :: Version
version} MutationConstraints {Maybe Bool
Maybe VersionRange
VersionBounds
mutation :: VersionBounds
oldest :: Maybe Bool
installed :: Maybe Bool
force :: Maybe VersionRange
prefer :: Maybe VersionRange
prefer :: MutationConstraints -> Maybe VersionRange
force :: MutationConstraints -> Maybe VersionRange
installed :: MutationConstraints -> Maybe Bool
oldest :: MutationConstraints -> Maybe Bool
mutation :: MutationConstraints -> VersionBounds
..}
  | Bool
retract
  , MutableDep -> PackageName
depName MutableId
candidate.name PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
name
  = MutationConstraints {mutation :: VersionBounds
mutation = Version -> VersionBounds
fromLower Version
version, oldest :: Maybe Bool
oldest = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True, Maybe Bool
Maybe VersionRange
installed :: Maybe Bool
force :: Maybe VersionRange
prefer :: Maybe VersionRange
prefer :: Maybe VersionRange
force :: Maybe VersionRange
installed :: Maybe Bool
..}
  | VersionBounds {lower :: VersionBounds -> Maybe Version
lower = Just Version
_} <- VersionBounds
mutation
  = MutationConstraints {mutation :: VersionBounds
mutation = Version -> VersionBounds
fromLower Version
version, Maybe Bool
Maybe VersionRange
oldest :: Maybe Bool
installed :: Maybe Bool
force :: Maybe VersionRange
prefer :: Maybe VersionRange
prefer :: Maybe VersionRange
force :: Maybe VersionRange
installed :: Maybe Bool
oldest :: Maybe Bool
..}
  | Bool
otherwise
  = MutationConstraints {mutation :: VersionBounds
mutation = Version -> VersionBounds
fromUpper Version
version, Maybe Bool
Maybe VersionRange
oldest :: Maybe Bool
installed :: Maybe Bool
force :: Maybe VersionRange
prefer :: Maybe VersionRange
prefer :: Maybe VersionRange
force :: Maybe VersionRange
installed :: Maybe Bool
oldest :: Maybe Bool
..}

success :: Map MutableDep BuildSuccess -> Natural -> Text
success :: Map MutableDep BuildSuccess -> Natural -> Text
success Map MutableDep BuildSuccess
_ Natural
iterations =
  [exon|Found stable lower bounds 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 lower bounds for some deps after #{describeIterations iterations}.|]

-- | This uses 'lowerInit' for the initial solver bounds, which gets translated to an extended bound treated as an
-- upper.
-- When a stable version was found, it will be set as a retracted bound, treated as a lower.
lowerStabilize ::
  BuildHandlers ->
  BuildConfig ->
  StageContext ->
  M StageResult
lowerStabilize :: BuildHandlers -> BuildConfig -> StageContext -> M StageResult
lowerStabilize BuildHandlers
handlers BuildConfig
conf StageContext
context =
  (Map MutableDep BuildSuccess -> Natural -> Text)
-> (Natural -> Text) -> StageState Lower 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 Lower SolverState -> StageResult)
-> M (StageState Lower SolverState) -> M StageResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (QueryDep -> M (Maybe (DepMutation Lower)))
-> MutationHandlers Lower SolverState
-> BuildConfig
-> StageContext
-> SolverState
-> M (StageState Lower SolverState)
forall a s.
Pretty a =>
(QueryDep -> M (Maybe (DepMutation a)))
-> MutationHandlers a s
-> BuildConfig
-> StageContext
-> s
-> M (StageState a s)
processQuery QueryDep -> M (Maybe (DepMutation Lower))
candidates MutationHandlers Lower SolverState
mutationHandlers BuildConfig
conf StageContext
context SolverState
ext
  where
    candidates :: QueryDep -> M (Maybe (DepMutation Lower))
candidates QueryDep
query = (PackageName -> M [Version])
-> QueryDep -> Maybe Version -> M (Maybe (DepMutation Lower))
candidatesStabilize BuildHandlers
handlers.versions QueryDep
query (Maybe (Maybe Version) -> Maybe Version
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (StageContext
context.initial MutableVersions -> MutableDep -> Maybe (Maybe Version)
forall map k v sort l.
(NMap map k v sort, NLookup sort k v l) =>
map -> k -> l
!! QueryDep
query.package))

    mutationHandlers :: MutationHandlers Lower SolverState
mutationHandlers = BuildConfig
-> LowerMode
-> (Bool
    -> MutableId
    -> PackageId
    -> MutationConstraints
    -> MutationConstraints)
-> MutationHandlers Lower SolverState
Mutation.handlersLower BuildConfig
conf LowerMode
lowerStabilizeMode Bool
-> MutableId
-> PackageId
-> MutationConstraints
-> MutationConstraints
lowerStabilizeUpdate

    ext :: SolverState
ext = Ranges -> EnvDeps -> EnvConstraints -> SolverFlags -> SolverState
solverState StageContext
context.env.solverBounds StageContext
context.env.deps ((Version -> VersionBounds) -> MutableVersions -> EnvConstraints
fromVersions Version -> VersionBounds
fromUpper StageContext
context.initial) SolverFlags
forall a. Default a => a
def

stabilizeStage ::
  BuildHandlers ->
  BuildConfig ->
  Flow ()
stabilizeStage :: BuildHandlers -> BuildConfig -> Flow ()
stabilizeStage BuildHandlers
handlers BuildConfig
conf =
  Text -> (StageContext -> M StageResult) -> Flow ()
runStage_ Text
"stabilize"  (BuildHandlers -> BuildConfig -> StageContext -> M StageResult
lowerStabilize BuildHandlers
handlers BuildConfig
conf)

stabilizeIfPossible ::
  BuildHandlers ->
  BuildConfig ->
  Flow ()
stabilizeIfPossible :: BuildHandlers -> BuildConfig -> Flow ()
stabilizeIfPossible BuildHandlers
handlers BuildConfig
conf =
  Flow BuildStatus
buildLowerInit Flow BuildStatus -> (BuildStatus -> Flow ()) -> Flow ()
forall a b. Flow a -> (a -> Flow b) -> Flow b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    BuildStatus
Success -> BuildHandlers -> BuildConfig -> Flow ()
stabilizeStage BuildHandlers
handlers BuildConfig
conf
    BuildStatus
Failure -> Flow ()
forall (f :: * -> *). Applicative f => f ()
unit

validateCurrent :: Flow BuildStatus
validateCurrent :: Flow BuildStatus
validateCurrent =
  Text -> (StageContext -> M StageSummary) -> Flow BuildStatus
execStatelessStage Text
"stabilize-current" \ StageContext {EnvContext
env :: StageContext -> EnvContext
env :: EnvContext
env, state :: StageContext -> Initial MutationState
state = Initial MutationState {MutableVersions
versions :: MutableVersions
versions :: MutationState -> MutableVersions
versions}, EnvBuilder
builder :: StageContext -> EnvBuilder
builder :: EnvBuilder
builder} ->
    EnvBuilder
-> EnvContext -> Text -> MutableVersions -> M BuildStatus
buildVersions EnvBuilder
builder EnvContext
env Text
"current lower bounds" MutableVersions
versions M BuildStatus -> (BuildStatus -> StageSummary) -> M StageSummary
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      BuildStatus
Success -> Maybe Text -> StageSummary
StageNoAction (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Env builds successfully with the current bounds.")
      BuildStatus
Failure -> StageFailure -> StageSummary
StageFailure (NonEmpty Text -> StageFailure
FailedPrecondition [Text
Item (NonEmpty Text)
"Env does not build successfully with the current bounds."])

lowerStabilizeStages ::
  BuildHandlers ->
  BuildConfig ->
  Flow ()
lowerStabilizeStages :: BuildHandlers -> BuildConfig -> Flow ()
lowerStabilizeStages BuildHandlers
handlers BuildConfig
conf =
  Flow BuildStatus
validateCurrent Flow BuildStatus -> (BuildStatus -> Flow ()) -> Flow ()
forall a b. Flow a -> (a -> Flow b) -> Flow b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    BuildStatus
Success -> Flow ()
forall (f :: * -> *). Applicative f => f ()
unit
    BuildStatus
_ -> BuildHandlers -> BuildConfig -> Flow ()
stabilizeIfPossible BuildHandlers
handlers BuildConfig
conf

lowerStabilizeMain ::
  BuildHandlers ->
  ProjectContext ->
  M ProjectResult
lowerStabilizeMain :: BuildHandlers -> ProjectContext -> M ProjectResult
lowerStabilizeMain BuildHandlers
handlers ProjectContext
project =
  BuildHandlers -> ProjectContext -> Flow () -> M ProjectResult
processProject BuildHandlers
handlers ProjectContext
project (BuildHandlers -> BuildConfig -> Flow ()
lowerStabilizeStages BuildHandlers
handlers ProjectContext
project.build)