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)
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))