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.Data.PackageName (LocalPackage (LocalPackage))
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.Mutable (MutableDep, depName)

data SolverFlags =
  SolverFlags {
    SolverFlags -> Bool
allowNewer :: Bool,
    SolverFlags -> Bool
forceRevisions :: Bool
  }
  deriving stock (SolverFlags -> SolverFlags -> Bool
(SolverFlags -> SolverFlags -> Bool)
-> (SolverFlags -> SolverFlags -> Bool) -> Eq SolverFlags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SolverFlags -> SolverFlags -> Bool
== :: SolverFlags -> SolverFlags -> Bool
$c/= :: SolverFlags -> SolverFlags -> Bool
/= :: SolverFlags -> SolverFlags -> Bool
Eq, Int -> SolverFlags -> ShowS
[SolverFlags] -> ShowS
SolverFlags -> String
(Int -> SolverFlags -> ShowS)
-> (SolverFlags -> String)
-> ([SolverFlags] -> ShowS)
-> Show SolverFlags
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SolverFlags -> ShowS
showsPrec :: Int -> SolverFlags -> ShowS
$cshow :: SolverFlags -> String
show :: SolverFlags -> String
$cshowList :: [SolverFlags] -> ShowS
showList :: [SolverFlags] -> ShowS
Show, (forall x. SolverFlags -> Rep SolverFlags x)
-> (forall x. Rep SolverFlags x -> SolverFlags)
-> Generic SolverFlags
forall x. Rep SolverFlags x -> SolverFlags
forall x. SolverFlags -> Rep SolverFlags x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SolverFlags -> Rep SolverFlags x
from :: forall x. SolverFlags -> Rep SolverFlags x
$cto :: forall x. Rep SolverFlags x -> SolverFlags
to :: forall x. Rep SolverFlags x -> SolverFlags
Generic)

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

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

compileSolverFlags :: SolverFlags -> DepResolverParams -> DepResolverParams
compileSolverFlags :: SolverFlags -> DepResolverParams -> DepResolverParams
compileSolverFlags SolverFlags {Bool
allowNewer :: SolverFlags -> Bool
forceRevisions :: SolverFlags -> Bool
allowNewer :: Bool
forceRevisions :: Bool
..} =
  (DepResolverParams -> DepResolverParams)
-> Bool -> DepResolverParams -> DepResolverParams
forall {a}. (a -> a) -> Bool -> a -> a
flag DepResolverParams -> DepResolverParams
flagAllowNewer Bool
allowNewer
  where
    flag :: (a -> a) -> Bool -> a -> a
flag a -> a
f Bool
v | Bool
v = a -> a
f
             | Bool
otherwise = a -> a
forall a. a -> a
id

data SolverState =
  UnsafeSolverState EnvConstraints SolverFlags
  deriving stock (SolverState -> SolverState -> Bool
(SolverState -> SolverState -> Bool)
-> (SolverState -> SolverState -> Bool) -> Eq SolverState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SolverState -> SolverState -> Bool
== :: SolverState -> SolverState -> Bool
$c/= :: SolverState -> SolverState -> Bool
/= :: SolverState -> SolverState -> Bool
Eq, Int -> SolverState -> ShowS
[SolverState] -> ShowS
SolverState -> String
(Int -> SolverState -> ShowS)
-> (SolverState -> String)
-> ([SolverState] -> ShowS)
-> Show SolverState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SolverState -> ShowS
showsPrec :: Int -> SolverState -> ShowS
$cshow :: SolverState -> String
show :: SolverState -> String
$cshowList :: [SolverState] -> ShowS
showList :: [SolverState] -> ShowS
Show)

pattern SolverState :: EnvConstraints -> SolverFlags -> SolverState
pattern $mSolverState :: forall {r}.
SolverState
-> (EnvConstraints -> SolverFlags -> r) -> ((# #) -> r) -> r
SolverState {()
constraints, ()
flags} <- UnsafeSolverState constraints flags

{-# complete SolverState #-}

instance HasField "constraints" SolverState EnvConstraints where
  getField :: SolverState -> EnvConstraints
getField (UnsafeSolverState EnvConstraints
c SolverFlags
_) = EnvConstraints
c

instance HasField "flags" SolverState SolverFlags where
  getField :: SolverState -> SolverFlags
getField (UnsafeSolverState EnvConstraints
_ SolverFlags
p) = SolverFlags
p

-- TODO What's the point of this now that there's no @local@ flag in the constraints anymore?
localDepConstraints :: Set LocalPackage -> EnvConstraints
localDepConstraints :: Set LocalPackage -> EnvConstraints
localDepConstraints =
  (LocalPackage -> (PackageName, MutationConstraints))
-> Set LocalPackage -> EnvConstraints
forall (t :: * -> *) map k v sort a.
(Foldable t, NMap map k v sort) =>
(a -> (k, v)) -> t a -> map
nGenWith \ (LocalPackage PackageName
package) -> (PackageName
package, MutationConstraints
noBounds)

mutableDepConstraints :: Set MutableDep -> EnvConstraints
mutableDepConstraints :: Set MutableDep -> EnvConstraints
mutableDepConstraints =
  (MutableDep -> (PackageName, MutationConstraints))
-> Set MutableDep -> EnvConstraints
forall (t :: * -> *) map k v sort a.
(Foldable t, NMap map k v sort) =>
(a -> (k, v)) -> t a -> map
nGenWith \ MutableDep
package -> (MutableDep -> PackageName
depName MutableDep
package, MutationConstraints
noBounds)

solverState ::
  Ranges ->
  EnvDeps ->
  EnvConstraints ->
  SolverFlags ->
  SolverState
solverState :: Ranges -> EnvDeps -> EnvConstraints -> SolverFlags -> SolverState
solverState Ranges
user EnvDeps
deps EnvConstraints
modeConstraints SolverFlags
flags =
  EnvConstraints -> SolverFlags -> SolverState
UnsafeSolverState EnvConstraints
constraints SolverFlags
flags
  where
    constraints :: EnvConstraints
constraints =
      EnvConstraints
modeConstraints EnvConstraints -> EnvConstraints -> EnvConstraints
forall a. Semigroup a => a -> a -> a
<>
      Ranges -> EnvConstraints
explicitBounds Ranges
user EnvConstraints -> EnvConstraints -> EnvConstraints
forall a. Semigroup a => a -> a -> a
<>
      Set LocalPackage -> EnvConstraints
localDepConstraints EnvDeps
deps.local EnvConstraints -> EnvConstraints -> EnvConstraints
forall a. Semigroup a => a -> a -> a
<>
      Set MutableDep -> EnvConstraints
mutableDepConstraints EnvDeps
deps.mutable

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