SolverState.hs

module Hix.Managed.Cabal.Data.SolverState (
  SolverState (SolverState, constraints, flags),
  solverState,
  updateSolverState,
  SolverFlags (..),
  compileSolverFlags,
) where

import Distribution.Client.Dependency (DepResolverParams, removeUpperBounds)
import Distribution.Client.Types (RelaxDeps (RelaxDepsAll))
import Distribution.Client.Types.AllowNewer (AllowNewer (AllowNewer))
import GHC.Records (HasField (getField))

import Hix.Class.Map (nGenWith)
import Hix.Data.Bounds (Ranges)
import Hix.Managed.Constraints (explicitBounds, noBounds)
import Hix.Managed.Data.Constraints (EnvConstraints)
import qualified Hix.Managed.Data.EnvContext
import Hix.Managed.Data.EnvContext (EnvDeps)
import Hix.Managed.Data.Initial (Initial (..))
import Hix.Managed.Data.Mutable (MutableDep, depName)

data SolverFlags =
  SolverFlags {
    allowNewer :: Bool,
    forceRevisions :: Bool
  }
  deriving stock (Eq, Show, Generic)

instance Default SolverFlags where
  def = SolverFlags {allowNewer = False, forceRevisions = False}

flagAllowNewer :: DepResolverParams -> DepResolverParams
flagAllowNewer =
  removeUpperBounds (AllowNewer RelaxDepsAll)

compileSolverFlags :: SolverFlags -> DepResolverParams -> DepResolverParams
compileSolverFlags SolverFlags {..} =
  flag flagAllowNewer allowNewer
  where
    flag f v | v = f
             | otherwise = id

data SolverState =
  UnsafeSolverState EnvConstraints SolverFlags
  deriving stock (Eq, Show)

pattern SolverState :: EnvConstraints -> SolverFlags -> SolverState
pattern SolverState {constraints, flags} <- UnsafeSolverState constraints flags

{-# complete SolverState #-}

instance HasField "constraints" SolverState EnvConstraints where
  getField (UnsafeSolverState c _) = c

instance HasField "flags" SolverState SolverFlags where
  getField (UnsafeSolverState _ p) = p

mutableDepConstraints :: Set MutableDep -> EnvConstraints
mutableDepConstraints =
  nGenWith \ package -> (depName package, noBounds)

solverState ::
  Ranges ->
  EnvDeps ->
  EnvConstraints ->
  SolverFlags ->
  Initial SolverState
solverState user deps modeConstraints flags =
  Initial (UnsafeSolverState constraints flags)
  where
    constraints =
      modeConstraints <>
      explicitBounds user <>
      mutableDepConstraints deps.mutable

updateSolverState :: (EnvConstraints -> EnvConstraints) -> SolverState -> SolverState
updateSolverState f (UnsafeSolverState c p) = UnsafeSolverState (f c) p