module Hix.Managed.Lower.Auto where

import qualified Data.Set as Set

import Hix.Class.Map (nToMaybe, nZipR)
import Hix.Data.Monad (M)
import Hix.Managed.Data.BuildConfig (BuildConfig)
import qualified Hix.Managed.Data.EnvState
import Hix.Managed.Data.EnvState (EnvState (EnvState))
import qualified Hix.Managed.Data.LowerConfig
import Hix.Managed.Data.LowerConfig (LowerConfig)
import Hix.Managed.Data.Mutable (MutableVersions)
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.QueryDep
import Hix.Managed.Data.StageContext (StageContext (StageContext, query))
import Hix.Managed.Data.StageState (BuildStatus (Failure, Success))
import Hix.Managed.Diff (reifyVersionChanges)
import Hix.Managed.Flow (Flow, evalStageState, runStage_, stageError)
import Hix.Managed.Handlers.Build (BuildHandlers)
import Hix.Managed.Lower.Init (lowerInitStage)
import Hix.Managed.Lower.Optimize (lowerOptimize)
import Hix.Managed.Lower.Stabilize (stabilizeIfPossible, stabilizeStage, validateCurrent)
import Hix.Managed.Process (processProject)

suggestStabilize :: Flow ()
suggestStabilize :: Flow ()
suggestStabilize = Text -> Flow ()
stageError Text
"Re-run with --stabilize to attempt to fix the bounds."

-- | This skips building with initial bounds because it only runs after LowerInit failed, which means that we have no
-- initial bounds.
stabilizeInitFailure ::
  BuildHandlers ->
  LowerConfig ->
  BuildConfig ->
  Flow ()
stabilizeInitFailure :: BuildHandlers -> LowerConfig -> BuildConfig -> Flow ()
stabilizeInitFailure BuildHandlers
handlers LowerConfig
conf BuildConfig
buildConf
  | LowerConfig
conf.stabilize
  = BuildHandlers -> BuildConfig -> Flow ()
stabilizeStage BuildHandlers
handlers BuildConfig
buildConf
  | Bool
otherwise
  = Flow ()
suggestStabilize

-- TODO needs some more work
pristineBounds :: EnvState -> Query -> Maybe Query
pristineBounds :: EnvState -> Query -> Maybe Query
pristineBounds EnvState {MutableDeps VersionChange
versions :: MutableDeps VersionChange
versions :: EnvState -> MutableDeps VersionChange
versions, MutableDeps VersionChange
initial :: MutableDeps VersionChange
initial :: EnvState -> MutableDeps VersionChange
initial} (Query NonEmpty QueryDep
query) =
  NonEmpty QueryDep -> Query
Query (NonEmpty QueryDep -> Query)
-> Maybe (NonEmpty QueryDep) -> Maybe Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QueryDep] -> Maybe (NonEmpty QueryDep)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([MutableDep] -> [QueryDep]
restrictQuery (MutableVersions
-> (MutableDep -> Maybe Version -> Maybe MutableDep)
-> [MutableDep]
forall map k v sort a.
NMap map k v sort =>
map -> (k -> v -> Maybe a) -> [a]
nToMaybe MutableVersions
pristine MutableDep -> Maybe Version -> Maybe MutableDep
forall {a} {a}. a -> Maybe a -> Maybe a
nameIfJust))
  where
    nameIfJust :: a -> Maybe a -> Maybe a
nameIfJust a
name = \case
      Just a
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
name
      Maybe a
Nothing -> Maybe a
forall a. Maybe a
Nothing

    restrictQuery :: [MutableDep] -> [QueryDep]
restrictQuery ([MutableDep] -> Set MutableDep
forall a. Ord a => [a] -> Set a
Set.fromList -> Set MutableDep
names) =
      (QueryDep -> Bool) -> [QueryDep] -> [QueryDep]
forall a. (a -> Bool) -> [a] -> [a]
filter ((MutableDep -> Set MutableDep -> Bool)
-> Set MutableDep -> MutableDep -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip MutableDep -> Set MutableDep -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set MutableDep
names (MutableDep -> Bool)
-> (QueryDep -> MutableDep) -> QueryDep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.package)) (NonEmpty QueryDep -> [QueryDep]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty QueryDep
query)

    pristine :: MutableVersions
    pristine :: MutableVersions
pristine = (Maybe (Maybe Version) -> Maybe Version -> Maybe Version)
-> MutableVersions -> MutableVersions -> MutableVersions
forall map1 map2 map3 k v1 v2 v3 s1 s2 s3.
(NMap map1 k v1 s1, NMap map2 k v2 s2, NMap map3 k v3 s3) =>
(Maybe v1 -> v2 -> v3) -> map1 -> map2 -> map3
nZipR Maybe (Maybe Version) -> Maybe Version -> Maybe Version
forall {a}. Eq a => Maybe (Maybe a) -> Maybe a -> Maybe a
justEqual (MutableDeps VersionChange -> MutableVersions
reifyVersionChanges MutableDeps VersionChange
initial) (MutableDeps VersionChange -> MutableVersions
reifyVersionChanges MutableDeps VersionChange
versions)

    justEqual :: Maybe (Maybe a) -> Maybe a -> Maybe a
justEqual (Just (Just a
ini)) (Just a
current) | a
ini a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
current = a -> Maybe a
forall a. a -> Maybe a
Just a
current
    justEqual Maybe (Maybe a)
_ Maybe a
_ = Maybe a
forall a. Maybe a
Nothing

-- | Return the current 'Query' without those deps whose current versions differ from their initial ones, i.e. that have
-- been optimized before.
pristineBoundsQuery :: Flow (Maybe Query)
pristineBoundsQuery :: Flow (Maybe Query)
pristineBoundsQuery =
  (EnvState -> StageContext -> Maybe Query) -> Flow (Maybe Query)
forall a. (EnvState -> StageContext -> a) -> Flow a
evalStageState \ EnvState
env StageContext {Query
query :: StageContext -> Query
query :: Query
query} -> EnvState -> Query -> Maybe Query
pristineBounds EnvState
env Query
query

-- | Run Optimize, but only consider the deps that have not been optimized before.
--
-- TODO this could use a flag for forcing optimization of all (query) deps.
optimizePristineBounds ::
  BuildHandlers ->
  BuildConfig ->
  Flow ()
optimizePristineBounds :: BuildHandlers -> BuildConfig -> Flow ()
optimizePristineBounds BuildHandlers
handlers BuildConfig
conf = do
  Flow (Maybe Query)
pristineBoundsQuery Flow (Maybe Query) -> (Maybe Query -> 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
    Just Query
newQuery ->
      Text -> (StageContext -> M StageResult) -> Flow ()
runStage_ Text
"auto-optimize" \ StageContext
context ->
        BuildHandlers -> BuildConfig -> StageContext -> M StageResult
lowerOptimize BuildHandlers
handlers BuildConfig
conf StageContext
context {query = newQuery}
    Maybe Query
Nothing -> Flow ()
forall (f :: * -> *). Applicative f => f ()
unit

postInit ::
  BuildHandlers ->
  LowerConfig ->
  BuildConfig ->
  Flow ()
postInit :: BuildHandlers -> LowerConfig -> BuildConfig -> Flow ()
postInit BuildHandlers
handlers LowerConfig
conf BuildConfig
buildConf =
  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 -> BuildHandlers -> BuildConfig -> Flow ()
optimizePristineBounds BuildHandlers
handlers BuildConfig
buildConf
    BuildStatus
Failure | LowerConfig
conf.stabilize -> BuildHandlers -> BuildConfig -> Flow ()
stabilizeIfPossible BuildHandlers
handlers BuildConfig
buildConf
            | Bool
otherwise -> Flow ()
suggestStabilize

lowerAutoStages ::
  BuildHandlers ->
  LowerConfig ->
  BuildConfig ->
  Flow ()
lowerAutoStages :: BuildHandlers -> LowerConfig -> BuildConfig -> Flow ()
lowerAutoStages BuildHandlers
handlers LowerConfig
conf BuildConfig
buildConf =
  BuildHandlers -> LowerConfig -> BuildConfig -> Flow BuildStatus
lowerInitStage BuildHandlers
handlers LowerConfig
conf BuildConfig
buildConf 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 | LowerConfig
conf.initOnly -> Flow ()
forall (f :: * -> *). Applicative f => f ()
unit
            | Bool
otherwise -> BuildHandlers -> LowerConfig -> BuildConfig -> Flow ()
postInit BuildHandlers
handlers LowerConfig
conf BuildConfig
buildConf
    BuildStatus
Failure -> BuildHandlers -> LowerConfig -> BuildConfig -> Flow ()
stabilizeInitFailure BuildHandlers
handlers LowerConfig
conf BuildConfig
buildConf

lowerAutoMain ::
  LowerConfig ->
  BuildHandlers ->
  ProjectContext ->
  M ProjectResult
lowerAutoMain :: LowerConfig -> BuildHandlers -> ProjectContext -> M ProjectResult
lowerAutoMain LowerConfig
conf BuildHandlers
handlers ProjectContext
project =
  BuildHandlers -> ProjectContext -> Flow () -> M ProjectResult
processProject BuildHandlers
handlers ProjectContext
project (BuildHandlers -> LowerConfig -> BuildConfig -> Flow ()
lowerAutoStages BuildHandlers
handlers LowerConfig
conf ProjectContext
project.build)