module Hix.Managed.Build where

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

import qualified Hix.Console
import Hix.Console (color, colors)
import Hix.Data.EnvName (EnvName (EnvName))
import Hix.Data.Monad (M)
import Hix.Data.Overrides (Overrides)
import qualified Hix.Data.PackageId
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.NixOutput (PackageDerivation (..))
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 (
  BuildFailure (PackageFailure, TimeoutFailure),
  BuildResult (BuildFailure, BuildSuccess),
  BuildStatus,
  StageState (failed, iterations),
  buildStatus,
  initStageState,
  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 #{color colors.yellow (coerce env)} with #{description}...|]
  Doc -> M ()
Log.debugP ([Doc] -> Doc
vcat [Item [Doc]
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}#{describePackages result}|]
  where
    describeResult :: BuildResult -> Text
describeResult = \case
      BuildResult
BuildSuccess -> Text
"succeeded"
      BuildFailure (TimeoutFailure [PackageId]
_) -> Text
"timed out"
      BuildFailure BuildFailure
_ -> Text
"failed"

    describePackages :: BuildResult -> Text
describePackages = \case
      BuildFailure (TimeoutFailure [PackageId]
pkgs) | Bool -> Bool
not ([PackageId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageId]
pkgs) -> [PackageId] -> Text
forall {a} {b}. (HasField "name" a b, Pretty b) => [a] -> Text
packageFragment [PackageId]
pkgs
      BuildFailure (PackageFailure NonEmpty PackageDerivation
pkgs) -> [PackageId] -> Text
forall {a} {b}. (HasField "name" a b, Pretty b) => [a] -> Text
packageFragment ((.package) (PackageDerivation -> PackageId)
-> [PackageDerivation] -> [PackageId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty PackageDerivation -> [PackageDerivation]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty PackageDerivation
pkgs)
      BuildResult
_ -> Text
""

    packageFragment :: [a] -> Text
packageFragment [a]
pkgs =
      [exon| in #{names}|]
      where
        names :: Text
names = Text -> [Text] -> Text
Text.intercalate Text
", " (Int -> Text -> Text
color ColorOffsets
colors.blue (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Text
forall b a. (Pretty a, IsString b) => a -> b
showP (b -> Text) -> (a -> b) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.name) (a -> Text) -> [a] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
pkgs)

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
bounds :: MutationState -> MutableBounds
bounds, MutableVersions
versions :: MutableVersions
versions :: MutationState -> MutableVersions
versions, MutableVersions
initial :: MutableVersions
initial :: MutationState -> MutableVersions
initial} =
  (Version -> VersionBounds -> VersionBounds)
-> MutationState -> MutationState
updateBoundsWith Version -> VersionBounds -> VersionBounds
updateBound MutationState {
    MutableBounds
bounds :: MutableBounds
bounds :: MutableBounds
bounds,
    versions :: MutableVersions
versions = Versions -> MutableVersions -> MutableVersions
addBuildVersions Versions
newVersions MutableVersions
versions,
    Overrides
overrides :: Overrides
overrides :: Overrides
overrides,
    MutableVersions
initial :: MutableVersions
initial :: MutableVersions
initial
  }

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

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

buildMutation ::
  EnvBuilder ->
  EnvContext ->
  MutationState ->
  Set PackageId ->
  BuildMutation ->
  M (Maybe (MutationState, Set PackageId))
buildMutation :: EnvBuilder
-> EnvContext
-> MutationState
-> Set PackageId
-> BuildMutation
-> M (Maybe (MutationState, Set PackageId))
buildMutation EnvBuilder
builder EnvContext
context MutationState
state Set PackageId
prevRevisions BuildMutation {Text
description :: Text
description :: BuildMutation -> Text
description, SolverState
solverState :: SolverState
solverState :: BuildMutation -> SolverState
solverState, Version -> VersionBounds -> VersionBounds
updateBound :: Version -> VersionBounds -> VersionBounds
updateBound :: BuildMutation -> Version -> VersionBounds -> VersionBounds
updateBound} =
  Maybe (Versions, Overrides, Set PackageId, BuildStatus)
-> Maybe (MutationState, Set PackageId)
result (Maybe (Versions, Overrides, Set PackageId, BuildStatus)
 -> Maybe (MutationState, Set PackageId))
-> M (Maybe (Versions, Overrides, Set PackageId, BuildStatus))
-> M (Maybe (MutationState, Set PackageId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnvBuilder
-> EnvContext
-> Text
-> Bool
-> Set PackageId
-> SolverState
-> M (Maybe (Versions, Overrides, Set PackageId, BuildStatus))
buildConstraints EnvBuilder
builder EnvContext
context Text
description Bool
True Set PackageId
prevRevisions SolverState
solverState
  where
    result :: Maybe (Versions, Overrides, Set PackageId, BuildStatus)
-> Maybe (MutationState, Set PackageId)
result = \case
      Just (Versions
versions, Overrides
overrides, Set PackageId
revisions, BuildStatus
status) -> do
        MutationState
new <- 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
        pure (MutationState
new, Set PackageId
revisions)
      Maybe (Versions, Overrides, Set PackageId, BuildStatus)
Nothing -> Maybe (MutationState, Set PackageId)
forall a. Maybe a
Nothing

logMutationResult ::
  MutableDep ->
  MutationResult s ->
  M ()
logMutationResult :: forall s. MutableDep -> MutationResult s -> M ()
logMutationResult MutableDep
package = \case
  MutationSuccess {MutableId
candidate :: MutableId
candidate :: forall s. MutationResult s -> MutableId
candidate, changed :: forall s. MutationResult s -> Bool
changed = Bool
True} ->
    Text -> M ()
Log.verbose [exon|Build succeeded for #{showP candidate}|]
  MutationSuccess {changed :: forall s. MutationResult s -> Bool
changed = Bool
False} ->
    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 #{color colors.blue (showP 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, Set PackageId))
build
    build :: BuildMutation -> M (Maybe (MutationState, Set PackageId))
build = EnvBuilder
-> EnvContext
-> MutationState
-> Set PackageId
-> BuildMutation
-> M (Maybe (MutationState, Set PackageId))
buildMutation EnvBuilder
envBuilder EnvContext
context StageState a s
stageState.state StageState a s
stageState.revisions

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 {iterations = 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 {failed = [], iterations = statePre.iterations + 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
env :: StageContext -> EnvContext
env, EnvBuilder
builder :: EnvBuilder
builder :: StageContext -> EnvBuilder
builder, Initial MutationState
state :: Initial MutationState
state :: StageContext -> Initial MutationState
state, query :: 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]
sortMutations :: CabalHandlers -> forall a. [DepMutation a] -> M [DepMutation a]
sortMutations} = EnvBuilder
builder.cabal