{-# language CPP #-}

module Hix.Managed.Cabal.Solve where

import Distribution.Client.Dependency (
  DepResolverParams,
  PackagePreference,
  PackageSpecifier,
  addPreferences,
  foldProgress,
  resolveDependencies,
  setAllowBootLibInstalls,
  standardInstallPolicy,
  )
import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import Distribution.Client.Types (UnresolvedSourcePackage)
import Distribution.Simple.Utils (debugNoWrap)
import Distribution.Solver.Types.Settings (AllowBootLibInstalls (AllowBootLibInstalls))
import Distribution.Verbosity (Verbosity)
import Exon (exon)

import Hix.Data.Error (Error (Fatal))
import qualified Hix.Log as Log
import Hix.Managed.Cabal.Changes (SolverPlan, solverPlan)
import qualified Hix.Managed.Cabal.Data.Config
import qualified Hix.Managed.Cabal.Data.SolveResources
import Hix.Managed.Cabal.Data.SolveResources (SolveResources)
import qualified Hix.Managed.Cabal.Data.SolveTarget
import Hix.Managed.Cabal.Data.SolveTarget (SolveTarget)
import qualified Hix.Managed.Cabal.Data.SolverState
import Hix.Managed.Cabal.Data.SolverState (SolverState (SolverState), compileSolverFlags)
import Hix.Managed.Cabal.Targets (solveTargets)
import Hix.Monad (M, tryIOMAs)

#if ! MIN_VERSION_Cabal(3,14,0)
import Distribution.Client.Dependency.Types (Solver (Modular))
#endif

newtype Unresolvable =
  Unresolvable Text
  deriving stock (Unresolvable -> Unresolvable -> Bool
(Unresolvable -> Unresolvable -> Bool)
-> (Unresolvable -> Unresolvable -> Bool) -> Eq Unresolvable
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Unresolvable -> Unresolvable -> Bool
== :: Unresolvable -> Unresolvable -> Bool
$c/= :: Unresolvable -> Unresolvable -> Bool
/= :: Unresolvable -> Unresolvable -> Bool
Eq, Int -> Unresolvable -> ShowS
[Unresolvable] -> ShowS
Unresolvable -> String
(Int -> Unresolvable -> ShowS)
-> (Unresolvable -> String)
-> ([Unresolvable] -> ShowS)
-> Show Unresolvable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Unresolvable -> ShowS
showsPrec :: Int -> Unresolvable -> ShowS
$cshow :: Unresolvable -> String
show :: Unresolvable -> String
$cshowList :: [Unresolvable] -> ShowS
showList :: [Unresolvable] -> ShowS
Show, (forall x. Unresolvable -> Rep Unresolvable x)
-> (forall x. Rep Unresolvable x -> Unresolvable)
-> Generic Unresolvable
forall x. Rep Unresolvable x -> Unresolvable
forall x. Unresolvable -> Rep Unresolvable x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Unresolvable -> Rep Unresolvable x
from :: forall x. Unresolvable -> Rep Unresolvable x
$cto :: forall x. Rep Unresolvable x -> Unresolvable
to :: forall x. Rep Unresolvable x -> Unresolvable
Generic)
  deriving newtype (String -> Unresolvable
(String -> Unresolvable) -> IsString Unresolvable
forall a. (String -> a) -> IsString a
$cfromString :: String -> Unresolvable
fromString :: String -> Unresolvable
IsString, Eq Unresolvable
Eq Unresolvable =>
(Unresolvable -> Unresolvable -> Ordering)
-> (Unresolvable -> Unresolvable -> Bool)
-> (Unresolvable -> Unresolvable -> Bool)
-> (Unresolvable -> Unresolvable -> Bool)
-> (Unresolvable -> Unresolvable -> Bool)
-> (Unresolvable -> Unresolvable -> Unresolvable)
-> (Unresolvable -> Unresolvable -> Unresolvable)
-> Ord Unresolvable
Unresolvable -> Unresolvable -> Bool
Unresolvable -> Unresolvable -> Ordering
Unresolvable -> Unresolvable -> Unresolvable
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Unresolvable -> Unresolvable -> Ordering
compare :: Unresolvable -> Unresolvable -> Ordering
$c< :: Unresolvable -> Unresolvable -> Bool
< :: Unresolvable -> Unresolvable -> Bool
$c<= :: Unresolvable -> Unresolvable -> Bool
<= :: Unresolvable -> Unresolvable -> Bool
$c> :: Unresolvable -> Unresolvable -> Bool
> :: Unresolvable -> Unresolvable -> Bool
$c>= :: Unresolvable -> Unresolvable -> Bool
>= :: Unresolvable -> Unresolvable -> Bool
$cmax :: Unresolvable -> Unresolvable -> Unresolvable
max :: Unresolvable -> Unresolvable -> Unresolvable
$cmin :: Unresolvable -> Unresolvable -> Unresolvable
min :: Unresolvable -> Unresolvable -> Unresolvable
Ord)

logMsg :: Verbosity -> String -> IO a -> IO a
logMsg :: forall a. Verbosity -> String -> IO a -> IO a
logMsg Verbosity
verbosity String
message IO a
rest =
  Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity String
message IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO a
rest

solveSpecifiers ::
  SolveResources ->
  (DepResolverParams -> DepResolverParams) ->
  [PackageSpecifier UnresolvedSourcePackage] ->
  [PackagePreference] ->
  IO (Either String SolverInstallPlan)
solveSpecifiers :: SolveResources
-> (DepResolverParams -> DepResolverParams)
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackagePreference]
-> IO (Either String SolverInstallPlan)
solveSpecifiers SolveResources
res DepResolverParams -> DepResolverParams
mapParams [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers [PackagePreference]
prefs =
  (String
 -> IO (Either String SolverInstallPlan)
 -> IO (Either String SolverInstallPlan))
-> (String -> IO (Either String SolverInstallPlan))
-> (SolverInstallPlan -> IO (Either String SolverInstallPlan))
-> Progress String String SolverInstallPlan
-> IO (Either String SolverInstallPlan)
forall step a fail done.
(step -> a -> a)
-> (fail -> a) -> (done -> a) -> Progress step fail done -> a
foldProgress (Verbosity
-> String
-> IO (Either String SolverInstallPlan)
-> IO (Either String SolverInstallPlan)
forall a. Verbosity -> String -> IO a -> IO a
logMsg SolveResources
res.conf.verbosity) (Either String SolverInstallPlan
-> IO (Either String SolverInstallPlan)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String SolverInstallPlan
 -> IO (Either String SolverInstallPlan))
-> (String -> Either String SolverInstallPlan)
-> String
-> IO (Either String SolverInstallPlan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String SolverInstallPlan
forall a b. a -> Either a b
Left) (Either String SolverInstallPlan
-> IO (Either String SolverInstallPlan)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String SolverInstallPlan
 -> IO (Either String SolverInstallPlan))
-> (SolverInstallPlan -> Either String SolverInstallPlan)
-> SolverInstallPlan
-> IO (Either String SolverInstallPlan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolverInstallPlan -> Either String SolverInstallPlan
forall a b. b -> Either a b
Right) (Progress String String SolverInstallPlan
 -> IO (Either String SolverInstallPlan))
-> Progress String String SolverInstallPlan
-> IO (Either String SolverInstallPlan)
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_Cabal(3,14,0)
  Platform
-> CompilerInfo
-> Maybe PkgConfigDb
-> DepResolverParams
-> Progress String String SolverInstallPlan
resolveDependencies SolveResources
res.platform SolveResources
res.compiler (PkgConfigDb -> Maybe PkgConfigDb
forall a. a -> Maybe a
Just SolveResources
res.pkgConfigDb) DepResolverParams
params
#else
  resolveDependencies res.platform res.compiler res.pkgConfigDb Modular params
#endif
  where
    params :: DepResolverParams
params =
      DepResolverParams -> DepResolverParams
mapParams (DepResolverParams -> DepResolverParams)
-> DepResolverParams -> DepResolverParams
forall a b. (a -> b) -> a -> b
$
      SolveResources
res.solverParams (DepResolverParams -> DepResolverParams)
-> DepResolverParams -> DepResolverParams
forall a b. (a -> b) -> a -> b
$
      AllowBootLibInstalls -> DepResolverParams -> DepResolverParams
setAllowBootLibInstalls (Bool -> AllowBootLibInstalls
AllowBootLibInstalls SolveResources
res.conf.allowBoot) (DepResolverParams -> DepResolverParams)
-> DepResolverParams -> DepResolverParams
forall a b. (a -> b) -> a -> b
$
      [PackagePreference] -> DepResolverParams -> DepResolverParams
addPreferences [PackagePreference]
prefs (DepResolverParams -> DepResolverParams)
-> DepResolverParams -> DepResolverParams
forall a b. (a -> b) -> a -> b
$
      InstalledPackageIndex
-> SourcePackageDb
-> [PackageSpecifier UnresolvedSourcePackage]
-> DepResolverParams
standardInstallPolicy SolveResources
res.installedPkgIndex SolveResources
res.sourcePkgDb [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers

solveForTargets ::
  SolveResources ->
  (DepResolverParams -> DepResolverParams) ->
  [SolveTarget] ->
  M (Either Unresolvable SolverInstallPlan)
solveForTargets :: SolveResources
-> (DepResolverParams -> DepResolverParams)
-> [SolveTarget]
-> M (Either Unresolvable SolverInstallPlan)
solveForTargets SolveResources
res DepResolverParams -> DepResolverParams
mapParams [SolveTarget]
targets =
  (String -> Unresolvable)
-> Either String SolverInstallPlan
-> Either Unresolvable SolverInstallPlan
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Unresolvable
forall a. IsString a => String -> a
fromString (Either String SolverInstallPlan
 -> Either Unresolvable SolverInstallPlan)
-> M (Either String SolverInstallPlan)
-> M (Either Unresolvable SolverInstallPlan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Error
-> IO (Either String SolverInstallPlan)
-> M (Either String SolverInstallPlan)
forall a. Error -> IO a -> M a
tryIOMAs (Text -> Error
Fatal Text
"Cabal solver crashed.") (SolveResources
-> (DepResolverParams -> DepResolverParams)
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackagePreference]
-> IO (Either String SolverInstallPlan)
solveSpecifiers SolveResources
res DepResolverParams -> DepResolverParams
mapParams [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers [PackagePreference]
prefs)
  where
    pkgSpecifiers :: [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers = (.dep) (SolveTarget -> PackageSpecifier UnresolvedSourcePackage)
-> [SolveTarget] -> [PackageSpecifier UnresolvedSourcePackage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SolveTarget]
targets
    prefs :: [PackagePreference]
prefs = (.prefs) (SolveTarget -> [PackagePreference])
-> [SolveTarget] -> [PackagePreference]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [SolveTarget]
targets

solveWithCabal' ::
  SolveResources ->
  SolverState ->
  M (Maybe SolverInstallPlan)
solveWithCabal' :: SolveResources -> SolverState -> M (Maybe SolverInstallPlan)
solveWithCabal' SolveResources
solveResources SolverState {EnvConstraints
constraints :: EnvConstraints
constraints :: ()
constraints, SolverFlags
flags :: SolverFlags
flags :: ()
flags} = do
  SolveResources
-> (DepResolverParams -> DepResolverParams)
-> [SolveTarget]
-> M (Either Unresolvable SolverInstallPlan)
solveForTargets SolveResources
solveResources (SolverFlags -> DepResolverParams -> DepResolverParams
compileSolverFlags SolverFlags
flags) [SolveTarget]
targets M (Either Unresolvable SolverInstallPlan)
-> (Either Unresolvable SolverInstallPlan
    -> M (Maybe SolverInstallPlan))
-> M (Maybe SolverInstallPlan)
forall a b. M a -> (a -> M b) -> M b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right SolverInstallPlan
plan ->
      Maybe SolverInstallPlan -> M (Maybe SolverInstallPlan)
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SolverInstallPlan -> Maybe SolverInstallPlan
forall a. a -> Maybe a
Just SolverInstallPlan
plan)
    Left Unresolvable
err -> do
      Text -> M ()
Log.debug [exon|Solver found no plan: ##{err}|]
      pure Maybe SolverInstallPlan
forall a. Maybe a
Nothing
  where
    targets :: [SolveTarget]
targets = EnvConstraints -> [SolveTarget]
solveTargets EnvConstraints
constraints

solveWithCabal ::
  SolveResources ->
  SolverState ->
  M (Maybe SolverPlan)
solveWithCabal :: SolveResources -> SolverState -> M (Maybe SolverPlan)
solveWithCabal SolveResources
solveResources SolverState
solverState =
  (SolverInstallPlan -> SolverPlan)
-> Maybe SolverInstallPlan -> Maybe SolverPlan
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SolverInstallPlan -> SolverPlan
solverPlan (Maybe SolverInstallPlan -> Maybe SolverPlan)
-> M (Maybe SolverInstallPlan) -> M (Maybe SolverPlan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SolveResources -> SolverState -> M (Maybe SolverInstallPlan)
solveWithCabal' SolveResources
solveResources SolverState
solverState