module Hix.Managed.Build where

import Control.Monad (foldM)
import qualified Data.Map.Strict as Map
import Distribution.Pretty (Pretty)
import Exon (exon)
import Text.PrettyPrint (vcat)

import Hix.Data.EnvName (EnvName)
import Hix.Data.Monad (M)
import Hix.Data.Overrides (Overrides)
import Hix.Data.PackageId (PackageId)
import Hix.Data.Version (Version, Versions)
import Hix.Data.VersionBounds (VersionBounds)
import qualified Hix.Log as Log
import Hix.Managed.Build.Solve (solveMutation)
import qualified Hix.Managed.Cabal.Changes
import Hix.Managed.Cabal.Config (isNonReinstallableDep, isReinstallableId)
import Hix.Managed.Cabal.Data.SolverState (SolverState)
import qualified Hix.Managed.Data.BuildConfig
import Hix.Managed.Data.BuildConfig (BuildConfig)
import qualified Hix.Managed.Data.EnvContext
import Hix.Managed.Data.EnvContext (EnvContext)
import Hix.Managed.Data.Mutable (MutableDep, addBuildVersions)
import qualified Hix.Managed.Data.Mutation
import Hix.Managed.Data.Mutation (BuildMutation (BuildMutation), DepMutation, MutationResult (..))
import qualified Hix.Managed.Data.MutationState
import Hix.Managed.Data.MutationState (MutationState (MutationState), updateBoundsWith)
import Hix.Managed.Data.Query (Query (Query))
import qualified Hix.Managed.Data.QueryDep
import Hix.Managed.Data.QueryDep (QueryDep)
import qualified Hix.Managed.Data.StageContext
import Hix.Managed.Data.StageContext (StageContext (StageContext))
import qualified Hix.Managed.Data.StageState
import Hix.Managed.Data.StageState (
  BuildResult (Finished, TimedOut),
  BuildStatus (Failure, Success),
  StageState,
  buildStatus,
  failed,
  initStageState,
  iterations,
  justSuccess,
  )
import qualified Hix.Managed.Handlers.Build
import Hix.Managed.Handlers.Build (EnvBuilder)
import qualified Hix.Managed.Handlers.Cabal
import Hix.Managed.Handlers.Cabal (CabalHandlers (CabalHandlers))
import qualified Hix.Managed.Handlers.Mutation
import Hix.Managed.Handlers.Mutation (MutationHandlers)
import Hix.Managed.StageState (updateStageState)
import Hix.Pretty (prettyL, showP, showPL)

logBuildInputs ::
  EnvName ->
  Text ->
  [PackageId] ->
  M ()
logBuildInputs :: EnvName -> Text -> [PackageId] -> M ()
logBuildInputs EnvName
env Text
description [PackageId]
overrides = do
  Text -> M ()
Log.info [exon|Building targets in '##{env}' with #{description}...|]
  Doc -> M ()
Log.debugP ([Doc] -> Doc
vcat [Doc
Item [Doc]
"Overrides:", [PackageId] -> Doc
forall (t :: * -> *) a. (Pretty a, Foldable t) => t a -> Doc
prettyL [PackageId]
overrides])

logBuildResult :: Text -> BuildResult -> M ()
logBuildResult :: Text -> BuildResult -> M ()
logBuildResult Text
description BuildResult
result =
  Text -> M ()
Log.info [exon|Build with ##{description} #{describeResult result}|]
  where
    describeResult :: BuildResult -> Text
describeResult = \case
      Finished BuildStatus
Success -> Text
"succeeded"
      Finished BuildStatus
Failure -> Text
"failed"
      BuildResult
TimedOut -> Text
"timed out"

updateMutationState ::
  (Version -> VersionBounds -> VersionBounds) ->
  Versions ->
  Overrides ->
  MutationState ->
  MutationState
updateMutationState :: (Version -> VersionBounds -> VersionBounds)
-> Versions -> Overrides -> MutationState -> MutationState
updateMutationState Version -> VersionBounds -> VersionBounds
updateBound Versions
newVersions Overrides
overrides MutationState {MutableBounds
bounds :: MutableBounds
$sel:bounds:MutationState :: MutationState -> MutableBounds
bounds, MutableVersions
versions :: MutableVersions
$sel:versions:MutationState :: MutationState -> MutableVersions
versions, MutableVersions
initial :: MutableVersions
$sel:initial:MutationState :: MutationState -> MutableVersions
initial} =
  (Version -> VersionBounds -> VersionBounds)
-> MutationState -> MutationState
updateBoundsWith Version -> VersionBounds -> VersionBounds
updateBound MutationState {
    MutableBounds
bounds :: MutableBounds
$sel:bounds:MutationState :: MutableBounds
bounds,
    $sel:versions:MutationState :: MutableVersions
versions = Versions -> MutableVersions -> MutableVersions
addBuildVersions Versions
newVersions MutableVersions
versions,
    Overrides
overrides :: Overrides
$sel:overrides:MutationState :: Overrides
overrides,
    MutableVersions
initial :: MutableVersions
$sel:initial:MutationState :: MutableVersions
initial
  }

-- | /Note/: This quietly discards non-reinstallable packages.
--
-- TODO Discard installed versions, for builds with initial versions.
buildVersions ::
  EnvBuilder ->
  EnvContext ->
  Text ->
  Versions ->
  [PackageId] ->
  M (Overrides, BuildStatus)
buildVersions :: EnvBuilder
-> EnvContext
-> Text
-> Versions
-> [PackageId]
-> M (Overrides, BuildStatus)
buildVersions EnvBuilder
builder EnvContext
context Text
description Versions
versions [PackageId]
overrideVersions = do
  EnvName -> Text -> [PackageId] -> M ()
logBuildInputs EnvContext
context.env Text
description [PackageId]
reinstallable
  (Overrides
overrides, BuildResult
status) <- EnvBuilder
builder.buildWithState Versions
versions [PackageId]
reinstallable
  Text -> BuildResult -> M ()
logBuildResult Text
description BuildResult
status
  pure (Overrides
overrides, BuildResult -> BuildStatus
buildStatus BuildResult
status)
  where
    reinstallable :: [PackageId]
reinstallable = (PackageId -> Bool) -> [PackageId] -> [PackageId]
forall a. (a -> Bool) -> [a] -> [a]
filter PackageId -> Bool
isReinstallableId [PackageId]
overrideVersions

buildConstraints ::
  EnvBuilder ->
  EnvContext ->
  Text ->
  SolverState ->
  M (Maybe (Versions, Overrides, BuildStatus))
buildConstraints :: EnvBuilder
-> EnvContext
-> Text
-> SolverState
-> M (Maybe (Versions, Overrides, BuildStatus))
buildConstraints EnvBuilder
builder EnvContext
context Text
description SolverState
state =
  CabalHandlers -> EnvDeps -> SolverState -> M (Maybe SolverChanges)
solveMutation EnvBuilder
builder.cabal EnvContext
context.deps SolverState
state M (Maybe SolverChanges)
-> (Maybe SolverChanges
    -> M (Maybe (Versions, Overrides, BuildStatus)))
-> M (Maybe (Versions, Overrides, BuildStatus))
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SolverChanges -> M (Versions, Overrides, BuildStatus))
-> Maybe SolverChanges
-> M (Maybe (Versions, Overrides, BuildStatus))
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) -> Maybe a -> f (Maybe b)
traverse \ SolverChanges
changes -> do
    (Overrides
overrides, BuildStatus
status) <- EnvBuilder
-> EnvContext
-> Text
-> Versions
-> [PackageId]
-> M (Overrides, BuildStatus)
buildVersions EnvBuilder
builder EnvContext
context Text
description SolverChanges
changes.versions SolverChanges
changes.overrides
    (Versions, Overrides, BuildStatus)
-> M (Versions, Overrides, BuildStatus)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SolverChanges
changes.versions, Overrides
overrides, BuildStatus
status)

buildMutation ::
  EnvBuilder ->
  EnvContext ->
  MutationState ->
  BuildMutation ->
  M (Maybe MutationState)
buildMutation :: EnvBuilder
-> EnvContext
-> MutationState
-> BuildMutation
-> M (Maybe MutationState)
buildMutation EnvBuilder
builder EnvContext
context MutationState
state BuildMutation {Text
description :: Text
$sel:description:BuildMutation :: BuildMutation -> Text
description, SolverState
solverState :: SolverState
$sel:solverState:BuildMutation :: BuildMutation -> SolverState
solverState, Version -> VersionBounds -> VersionBounds
updateBound :: Version -> VersionBounds -> VersionBounds
$sel:updateBound:BuildMutation :: BuildMutation -> Version -> VersionBounds -> VersionBounds
updateBound} =
  Maybe (Versions, Overrides, BuildStatus) -> Maybe MutationState
result (Maybe (Versions, Overrides, BuildStatus) -> Maybe MutationState)
-> M (Maybe (Versions, Overrides, BuildStatus))
-> M (Maybe MutationState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnvBuilder
-> EnvContext
-> Text
-> SolverState
-> M (Maybe (Versions, Overrides, BuildStatus))
buildConstraints EnvBuilder
builder EnvContext
context Text
description SolverState
solverState
  where
    result :: Maybe (Versions, Overrides, BuildStatus) -> Maybe MutationState
result = \case
      Just (Versions
versions, Overrides
overrides, BuildStatus
status) ->
        MutationState -> BuildStatus -> Maybe MutationState
forall a. a -> BuildStatus -> Maybe a
justSuccess ((Version -> VersionBounds -> VersionBounds)
-> Versions -> Overrides -> MutationState -> MutationState
updateMutationState Version -> VersionBounds -> VersionBounds
updateBound Versions
versions Overrides
overrides MutationState
state) BuildStatus
status
      Maybe (Versions, Overrides, BuildStatus)
Nothing -> Maybe MutationState
forall a. Maybe a
Nothing

logMutationResult ::
  MutableDep ->
  MutationResult s ->
  M ()
logMutationResult :: forall s. MutableDep -> MutationResult s -> M ()
logMutationResult MutableDep
package = \case
  MutationSuccess MutableId
candidate Bool
True MutationState
_ s
_ ->
    Text -> M ()
Log.verbose [exon|Build succeeded for #{showP candidate}|]
  MutationSuccess MutableId
_ Bool
False MutationState
_ s
_ ->
    Text -> M ()
Log.verbose [exon|Build is up to date for '##{package}'|]
  MutationResult s
MutationKeep ->
    Text -> M ()
Log.verbose [exon|No better version found for '##{package}'|]
  MutationResult s
MutationFailed ->
    Text -> M ()
Log.verbose [exon|Could not find a buildable version of '##{package}'|]

validateMutation ::
  EnvBuilder ->
  EnvContext ->
  MutationHandlers a s ->
  StageState a s ->
  DepMutation a ->
  M (StageState a s)
validateMutation :: forall a s.
EnvBuilder
-> EnvContext
-> MutationHandlers a s
-> StageState a s
-> DepMutation a
-> M (StageState a s)
validateMutation EnvBuilder
envBuilder EnvContext
context MutationHandlers a s
handlers StageState a s
stageState DepMutation a
mutation = do
  MutationResult s
result <- M (MutationResult s)
processReinstallable
  MutableDep -> MutationResult s -> M ()
forall s. MutableDep -> MutationResult s -> M ()
logMutationResult DepMutation a
mutation.package MutationResult s
result
  pure (StageState a s
-> DepMutation a -> MutationResult s -> StageState a s
forall a s.
StageState a s
-> DepMutation a -> MutationResult s -> StageState a s
updateStageState StageState a s
stageState DepMutation a
mutation MutationResult s
result)
  where
    processReinstallable :: M (MutationResult s)
processReinstallable
      | MutableDep -> Bool
isNonReinstallableDep DepMutation a
mutation.package
      = MutationResult s -> M (MutationResult s)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MutationResult s
forall s. MutationResult s
MutationKeep
      | Bool
otherwise
      = MutationHandlers a s
handlers.process StageState a s
stageState.ext DepMutation a
mutation BuildMutation -> M (Maybe MutationState)
build
    build :: BuildMutation -> M (Maybe MutationState)
build = EnvBuilder
-> EnvContext
-> MutationState
-> BuildMutation
-> M (Maybe MutationState)
buildMutation EnvBuilder
envBuilder EnvContext
context StageState a s
stageState.state

convergeMutations ::
  Pretty a =>
  MutationHandlers a s ->
  BuildConfig ->
  EnvBuilder ->
  EnvContext ->
  StageState a s ->
  [DepMutation a] ->
  M (StageState a s)
convergeMutations :: forall a s.
Pretty a =>
MutationHandlers a s
-> BuildConfig
-> EnvBuilder
-> EnvContext
-> StageState a s
-> [DepMutation a]
-> M (StageState a s)
convergeMutations MutationHandlers a s
handlers BuildConfig
conf EnvBuilder
builder EnvContext
context StageState a s
state0 =
  StageState a s -> [DepMutation a] -> M (StageState a s)
spin StageState a s
state0 {$sel:iterations:StageState :: Natural
iterations = Natural
0}
  where
    spin :: StageState a s -> [DepMutation a] -> M (StageState a s)
spin StageState a s
state [DepMutation a]
mutations

      | [] <- [DepMutation a]
mutations
      = StageState a s -> M (StageState a s)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StageState a s
state

      | StageState a s
state.iterations Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= BuildConfig
conf.maxIterations
      = StageState a s -> M (StageState a s)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StageState a s
state

      | Bool
otherwise
      = do
        Text -> M ()
Log.debug [exon|Iteration #{show (state.iterations + 1)} for '##{context.env :: EnvName}'|]
        StageState a s
newState <- StageState a s -> [DepMutation a] -> M (StageState a s)
build StageState a s
state [DepMutation a]
mutations
        if Map MutableDep BuildSuccess -> Int
forall k a. Map k a -> Int
Map.size StageState a s
newState.success Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Map MutableDep BuildSuccess -> Int
forall k a. Map k a -> Int
Map.size StageState a s
state.success
        then StageState a s -> M (StageState a s)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StageState a s
newState
        -- reversing so the build order is consistent
        else StageState a s -> [DepMutation a] -> M (StageState a s)
spin StageState a s
newState ([DepMutation a] -> [DepMutation a]
forall a. [a] -> [a]
reverse StageState a s
newState.failed)

    build :: StageState a s -> [DepMutation a] -> M (StageState a s)
build StageState a s
statePre [DepMutation a]
mutations = do
      let state :: StageState a s
state = StageState a s
statePre {$sel:failed:StageState :: [DepMutation a]
failed = [], $sel:iterations:StageState :: Natural
iterations = StageState a s
statePre.iterations Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1}
      Text -> M ()
Log.debug [exon|Building targets with mutations: #{showPL mutations}|]
      (StageState a s -> DepMutation a -> M (StageState a s))
-> StageState a s -> [DepMutation a] -> M (StageState a s)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (EnvBuilder
-> EnvContext
-> MutationHandlers a s
-> StageState a s
-> DepMutation a
-> M (StageState a s)
forall a s.
EnvBuilder
-> EnvContext
-> MutationHandlers a s
-> StageState a s
-> DepMutation a
-> M (StageState a s)
validateMutation EnvBuilder
builder EnvContext
context MutationHandlers a s
handlers) StageState a s
state [DepMutation a]
mutations

reinstallableCandidates ::
  (QueryDep -> M (Maybe (DepMutation a))) ->
  Query ->
  M [DepMutation a]
reinstallableCandidates :: forall a.
(QueryDep -> M (Maybe (DepMutation a)))
-> Query -> M [DepMutation a]
reinstallableCandidates QueryDep -> M (Maybe (DepMutation a))
candidates (Query NonEmpty QueryDep
query) =
  [Maybe (DepMutation a)] -> [DepMutation a]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (DepMutation a)] -> [DepMutation a])
-> M [Maybe (DepMutation a)] -> M [DepMutation a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (QueryDep -> M (Maybe (DepMutation a)))
-> [QueryDep] -> M [Maybe (DepMutation a)]
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 QueryDep -> M (Maybe (DepMutation a))
reinstallableOnly (NonEmpty QueryDep -> [QueryDep]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty QueryDep
query)
  where
    reinstallableOnly :: QueryDep -> M (Maybe (DepMutation a))
reinstallableOnly QueryDep
dep
      | MutableDep -> Bool
isNonReinstallableDep QueryDep
dep.package
      = Maybe (DepMutation a) -> M (Maybe (DepMutation a))
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (DepMutation a)
forall a. Maybe a
Nothing
      | Bool
otherwise
      = QueryDep -> M (Maybe (DepMutation a))
candidates QueryDep
dep

processQuery ::
  Pretty a =>
  (QueryDep -> M (Maybe (DepMutation a))) ->
  MutationHandlers a s ->
  BuildConfig ->
  StageContext ->
  s ->
  M (StageState a s)
processQuery :: 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 a))
candidates MutationHandlers a s
handlers BuildConfig
conf 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, $sel:query:StageContext :: StageContext -> Query
query = Query
query} s
ext = do
  [DepMutation a]
mutations <- [DepMutation a] -> M [DepMutation a]
postprocess ([DepMutation a] -> M [DepMutation a])
-> M [DepMutation a] -> M [DepMutation a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (QueryDep -> M (Maybe (DepMutation a)))
-> Query -> M [DepMutation a]
forall a.
(QueryDep -> M (Maybe (DepMutation a)))
-> Query -> M [DepMutation a]
reinstallableCandidates QueryDep -> M (Maybe (DepMutation a))
candidates Query
query
  MutationHandlers a s
-> BuildConfig
-> EnvBuilder
-> EnvContext
-> StageState a s
-> [DepMutation a]
-> M (StageState a s)
forall a s.
Pretty a =>
MutationHandlers a s
-> BuildConfig
-> EnvBuilder
-> EnvContext
-> StageState a s
-> [DepMutation a]
-> M (StageState a s)
convergeMutations MutationHandlers a s
handlers BuildConfig
conf EnvBuilder
builder EnvContext
env StageState a s
stageState [DepMutation a]
mutations
  where
    postprocess :: [DepMutation a] -> M [DepMutation a]
postprocess | BuildConfig
conf.toposortMutations = [DepMutation a] -> M [DepMutation a]
forall a. [DepMutation a] -> M [DepMutation a]
sortMutations
                | Bool
otherwise = [DepMutation a] -> M [DepMutation a]
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    stageState :: StageState a s
stageState = Initial MutationState -> s -> StageState a s
forall s a. Initial MutationState -> s -> StageState a s
initStageState Initial MutationState
state s
ext
    CabalHandlers {forall a. [DepMutation a] -> M [DepMutation a]
sortMutations :: forall a. [DepMutation a] -> M [DepMutation a]
$sel:sortMutations:CabalHandlers :: CabalHandlers -> forall a. [DepMutation a] -> M [DepMutation a]
sortMutations} = EnvBuilder
builder.cabal