module Hix.Managed.Build.Solve where

import Data.List (partition)
import qualified Data.Set as Set
import Distribution.PackageDescription (customFieldsPD)
import Distribution.Pretty (pretty)
import Exon (exon)
import Text.PrettyPrint (hang, ($$), (<+>))

import Hix.Class.Map (nRestrictKeys)
import Hix.Data.Monad (M)
import qualified Hix.Data.PackageId
import Hix.Data.PackageId (PackageId (PackageId))
import Hix.Data.PackageName (isLocalPackage)
import Hix.Data.Version (packageIdVersions)
import qualified Hix.Log as Log
import qualified Hix.Managed.Cabal.Changes
import Hix.Managed.Cabal.Changes (SolverChanges (SolverChanges), SolverPlan (SolverPlan))
import qualified Hix.Managed.Cabal.Data.SolverState
import Hix.Managed.Cabal.Data.SolverState (SolverState)
import qualified Hix.Managed.Data.EnvContext
import Hix.Managed.Data.EnvContext (EnvDeps)
import Hix.Managed.Data.Mutable (depName)
import qualified Hix.Managed.Handlers.Cabal
import Hix.Managed.Handlers.Cabal (CabalHandlers)
import Hix.Pretty (prettyL, showPL)

logNonReinstallable :: NonEmpty PackageId -> M ()
logNonReinstallable :: NonEmpty PackageId -> M ()
logNonReinstallable NonEmpty PackageId
ids =
  Text -> M ()
Log.verbose [exon|NOTE: Cabal solver suggested new versions for non-reinstallable packages: #{showPL ids}|]

checkRevision ::
  Bool ->
  CabalHandlers ->
  PackageId ->
  Either PackageId PackageId
checkRevision :: Bool -> CabalHandlers -> PackageId -> Either PackageId PackageId
checkRevision Bool
forceRevisions CabalHandlers
cabal PackageId
package
  | Bool
forceRevisions
  , Just PackageDescription
packageDesc <- CabalHandlers
cabal.sourcePackage PackageId
package
  , ((String, String) -> Bool) -> [(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String, String) -> Bool
isRevision PackageDescription
packageDesc.customFieldsPD
  = PackageId -> Either PackageId PackageId
forall a b. b -> Either a b
Right PackageId
package
  | Bool
otherwise
  = PackageId -> Either PackageId PackageId
forall a b. a -> Either a b
Left PackageId
package
  where
    isRevision :: (String, String) -> Bool
isRevision = \case
      (String
"x-revision", String
rev) | String
rev String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"0" -> Bool
True
      (String, String)
_ -> Bool
False

processSolverPlan ::
  Bool ->
  CabalHandlers ->
  EnvDeps ->
  Set PackageId ->
  SolverPlan ->
  M SolverChanges
processSolverPlan :: Bool
-> CabalHandlers
-> EnvDeps
-> Set PackageId
-> SolverPlan
-> M SolverChanges
processSolverPlan Bool
forceRevisions CabalHandlers
cabal EnvDeps
deps Set PackageId
prevRevisions SolverPlan {[PackageId]
Maybe (NonEmpty PackageId)
changes :: [PackageId]
matching :: [PackageId]
nonReinstallable :: Maybe (NonEmpty PackageId)
nonReinstallable :: SolverPlan -> Maybe (NonEmpty PackageId)
matching :: SolverPlan -> [PackageId]
changes :: SolverPlan -> [PackageId]
..} = do
  Doc -> M ()
Log.debugP (Doc -> M ()) -> Doc -> M ()
forall a b. (a -> b) -> a -> b
$
    Doc -> Int -> Doc -> Doc
hang Doc
"New project deps from solver:" Int
2 (Versions -> Doc
forall a. Pretty a => a -> Doc
pretty Versions
projectDeps) Doc -> Doc -> Doc
$$
    Doc
"Forced revisions:" Doc -> Doc -> Doc
<+> [PackageId] -> Doc
forall (t :: * -> *) a. (Pretty a, Foldable t) => t a -> Doc
prettyL [PackageId]
forcedRevisions Doc -> Doc -> Doc
$$
    Doc
"Reused revisions:" Doc -> Doc -> Doc
<+> [PackageId] -> Doc
forall (t :: * -> *) a. (Pretty a, Foldable t) => t a -> Doc
prettyL [PackageId]
reusedRevisions
  (NonEmpty PackageId -> M ()) -> Maybe (NonEmpty PackageId) -> M ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ NonEmpty PackageId -> M ()
logNonReinstallable Maybe (NonEmpty PackageId)
nonReinstallable
  pure SolverChanges {Versions
versions :: Versions
versions :: Versions
versions, [PackageId]
overrides :: [PackageId]
overrides :: [PackageId]
overrides, Versions
projectDeps :: Versions
projectDeps :: Versions
projectDeps}
  where
    projectDeps :: Versions
projectDeps = Set PackageName -> Versions -> Versions
forall map k v sort. NMap map k v sort => Set k -> map -> map
nRestrictKeys Set PackageName
mutablePIds Versions
versions
    versions :: Versions
versions = [PackageId] -> Versions
packageIdVersions ([PackageId]
overrides [PackageId] -> [PackageId] -> [PackageId]
forall a. [a] -> [a] -> [a]
++ [PackageId]
installed)
    overrides :: [PackageId]
overrides = (PackageId -> Bool) -> [PackageId] -> [PackageId]
forall a. (a -> Bool) -> [a] -> [a]
filter PackageId -> Bool
notLocal ([PackageId]
changes [PackageId] -> [PackageId] -> [PackageId]
forall a. [a] -> [a] -> [a]
++ [PackageId]
forcedRevisions [PackageId] -> [PackageId] -> [PackageId]
forall a. [a] -> [a] -> [a]
++ [PackageId]
reusedRevisions)
    ([PackageId]
reusedRevisions, [PackageId]
installed) = (PackageId -> Bool) -> [PackageId] -> ([PackageId], [PackageId])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((PackageId -> Set PackageId -> Bool)
-> Set PackageId -> PackageId -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageId -> Set PackageId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set PackageId
prevRevisions) [PackageId]
noForcedRevisions
    ([PackageId]
noForcedRevisions, [PackageId]
forcedRevisions) = [Either PackageId PackageId] -> ([PackageId], [PackageId])
forall a b. [Either a b] -> ([a], [b])
partitionEithers (Bool -> CabalHandlers -> PackageId -> Either PackageId PackageId
checkRevision Bool
forceRevisions CabalHandlers
cabal (PackageId -> Either PackageId PackageId)
-> [PackageId] -> [Either PackageId PackageId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageId]
matching)
    notLocal :: PackageId -> Bool
notLocal PackageId {PackageName
name :: PackageName
name :: PackageId -> PackageName
name} = Bool -> Bool
not (Set LocalPackage -> PackageName -> Bool
isLocalPackage EnvDeps
deps.local PackageName
name)
    mutablePIds :: Set PackageName
mutablePIds = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList (MutableDep -> PackageName
depName (MutableDep -> PackageName) -> [MutableDep] -> [PackageName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set MutableDep -> [MutableDep]
forall a. Set a -> [a]
Set.toList EnvDeps
deps.mutable)

-- TODO probably best to store the revisions in the SolverState
solveMutation ::
  CabalHandlers ->
  EnvDeps ->
  Set PackageId ->
  SolverState ->
  M (Maybe SolverChanges)
solveMutation :: CabalHandlers
-> EnvDeps
-> Set PackageId
-> SolverState
-> M (Maybe SolverChanges)
solveMutation CabalHandlers
cabal EnvDeps
deps Set PackageId
prevRevisions SolverState
state =
  (SolverPlan -> M SolverChanges)
-> Maybe SolverPlan -> M (Maybe SolverChanges)
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 (Bool
-> CabalHandlers
-> EnvDeps
-> Set PackageId
-> SolverPlan
-> M SolverChanges
processSolverPlan SolverState
state.flags.forceRevisions CabalHandlers
cabal EnvDeps
deps Set PackageId
prevRevisions) (Maybe SolverPlan -> M (Maybe SolverChanges))
-> M (Maybe SolverPlan) -> M (Maybe SolverChanges)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CabalHandlers
cabal.solveForVersion SolverState
state