module Hix.Managed.Lower.Init where

import Exon (exon)

import Hix.Class.Map (nCatMaybes, nKeysSet)
import Hix.Data.Monad (M)
import qualified Hix.Data.PackageId
import Hix.Data.PackageId (PackageId (PackageId))
import Hix.Data.Version (Version)
import Hix.Data.VersionBounds (fromUpper)
import Hix.Managed.Build (processQuery)
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 qualified Hix.Managed.Data.LowerConfig
import Hix.Managed.Data.LowerConfig (LowerConfig)
import Hix.Managed.Data.Mutable (MutableDep, MutableDeps)
import Hix.Managed.Data.MutableId (MutableId)
import qualified Hix.Managed.Data.ProjectContext
import Hix.Managed.Data.ProjectContext (ProjectContext)
import Hix.Managed.Data.ProjectResult (ProjectResult)
import qualified Hix.Managed.Data.StageContext
import Hix.Managed.Data.StageContext (StageContext)
import Hix.Managed.Data.StageResult (StageResult)
import Hix.Managed.Data.StageState (BuildStatus, BuildSuccess)
import Hix.Managed.Flow (Flow, execStage)
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 (candidatesInit)
import Hix.Managed.Lower.Data.LowerMode (lowerInitMode)
import Hix.Managed.Process (processProject)
import Hix.Managed.Report (describeIterations)
import Hix.Managed.StageResult (stageResultInit)

lowerInitUpdate :: Bool -> MutableId -> PackageId -> MutationConstraints -> MutationConstraints
lowerInitUpdate :: Bool
-> MutableId
-> PackageId
-> MutationConstraints
-> MutationConstraints
lowerInitUpdate Bool
_ MutableId
_ PackageId {Version
version :: Version
$sel:version:PackageId :: PackageId -> Version
version} MutationConstraints {Maybe Bool
Maybe VersionRange
VersionBounds
mutation :: VersionBounds
oldest :: Maybe Bool
installed :: Maybe Bool
force :: Maybe VersionRange
prefer :: Maybe VersionRange
$sel:mutation:MutationConstraints :: MutationConstraints -> VersionBounds
$sel:oldest:MutationConstraints :: MutationConstraints -> Maybe Bool
$sel:installed:MutationConstraints :: MutationConstraints -> Maybe Bool
$sel:force:MutationConstraints :: MutationConstraints -> Maybe VersionRange
$sel:prefer:MutationConstraints :: MutationConstraints -> Maybe VersionRange
..} =
  MutationConstraints {$sel:mutation:MutationConstraints :: VersionBounds
mutation = Version -> VersionBounds
fromUpper Version
version, Maybe Bool
Maybe VersionRange
oldest :: Maybe Bool
installed :: Maybe Bool
force :: Maybe VersionRange
prefer :: Maybe VersionRange
$sel:oldest:MutationConstraints :: Maybe Bool
$sel:installed:MutationConstraints :: Maybe Bool
$sel:force:MutationConstraints :: Maybe VersionRange
$sel:prefer:MutationConstraints :: Maybe VersionRange
..}

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

-- TODO This could instead only update the initial versions, so that a subsequent @lower.optimize@ can skip the versions
-- it elaborated before.
-- But it would require some nontrivial changes to the state update mechanisms.
--
-- | Determine initial lower bounds for the selected dependencies if they have none or @--reset@ was specified.
-- If none of the selected deps need to be processed, the state is not updated.
-- Otherwise, the lower bounds of _all_ deps are reset to the initial ones, requiring the user to run @lower.optimize@
-- again.
lowerInit ::
  BuildHandlers ->
  LowerConfig ->
  BuildConfig ->
  StageContext ->
  M StageResult
lowerInit :: BuildHandlers
-> LowerConfig -> BuildConfig -> StageContext -> M StageResult
lowerInit BuildHandlers
handlers LowerConfig
conf BuildConfig
buildConf StageContext
context = do
  StageState Lower SolverState
result <- (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
buildConf StageContext
context SolverState
ext
  pure ((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
stageResultInit Map MutableDep BuildSuccess -> Natural -> Text
success Natural -> Text
failure StageState Lower SolverState
result)
  where
    candidates :: QueryDep -> M (Maybe (DepMutation Lower))
candidates = (PackageName -> M [Version])
-> Set MutableDep -> QueryDep -> M (Maybe (DepMutation Lower))
candidatesInit BuildHandlers
handlers.versions (MutableDeps Version -> Set MutableDep
forall map k v sort. NMap map k v sort => map -> Set k
nKeysSet (MutableVersions -> MutableDeps Version
forall map1 k v sort1 map2 sort2.
(NMap map1 k (Maybe v) sort1, NMap map2 k v sort2) =>
map1 -> map2
nCatMaybes MutableVersions
keep :: MutableDeps Version))

    mutationHandlers :: MutationHandlers Lower SolverState
mutationHandlers = BuildConfig
-> LowerMode
-> (Bool
    -> MutableId
    -> PackageId
    -> MutationConstraints
    -> MutationConstraints)
-> MutationHandlers Lower SolverState
Mutation.handlersLower BuildConfig
buildConf LowerMode
lowerInitMode Bool
-> MutableId
-> PackageId
-> MutationConstraints
-> MutationConstraints
lowerInitUpdate

    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 MutableVersions
keep) SolverFlags
forall a. Default a => a
def

    keep :: MutableVersions
keep | LowerConfig
conf.reset = MutableVersions
forall a. Monoid a => a
mempty
         | Bool
otherwise = StageContext
context.initial

lowerInitStage ::
  BuildHandlers ->
  LowerConfig ->
  BuildConfig ->
  Flow BuildStatus
lowerInitStage :: BuildHandlers -> LowerConfig -> BuildConfig -> Flow BuildStatus
lowerInitStage BuildHandlers
handlers LowerConfig
conf BuildConfig
buildConf =
  Text -> (StageContext -> M StageResult) -> Flow BuildStatus
execStage Text
"lower-init" (BuildHandlers
-> LowerConfig -> BuildConfig -> StageContext -> M StageResult
lowerInit BuildHandlers
handlers LowerConfig
conf BuildConfig
buildConf)

lowerInitMain ::
  LowerConfig ->
  BuildHandlers ->
  ProjectContext ->
  M ProjectResult
lowerInitMain :: LowerConfig -> BuildHandlers -> ProjectContext -> M ProjectResult
lowerInitMain LowerConfig
conf 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 -> LowerConfig -> BuildConfig -> Flow BuildStatus
lowerInitStage BuildHandlers
handlers LowerConfig
conf ProjectContext
project.build))