module Hix.Managed.Cabal.Sort where

import qualified Data.Map.Strict as Map
import Data.Map.Strict ((!?))
import Distribution.Client.SolverInstallPlan (topologicalOrder)
import Exon (exon)

import Hix.Data.Monad (M)
import qualified Hix.Data.PackageId
import qualified Hix.Log as Log
import Hix.Managed.Cabal.Data.SolveResources (SolveResources)
import Hix.Managed.Cabal.Print (resolverPackageId)
import Hix.Managed.Cabal.Solve (solveForTargets)
import Hix.Managed.Cabal.Targets (solveTarget)
import Hix.Managed.Data.Mutable (MutableDep (MutableDep))
import Hix.Managed.Data.Mutation (DepMutation (..))
import Hix.Data.PackageName (PackageName)

sortDeps ::
  ∀ a .
  SolveResources ->
  (a -> PackageName) ->
  [a] ->
  M [a]
sortDeps :: forall a. SolveResources -> (a -> PackageName) -> [a] -> M [a]
sortDeps SolveResources
resources a -> PackageName
name [a]
mutations =
  SolveResources
-> (DepResolverParams -> DepResolverParams)
-> [SolveTarget]
-> M (Either Unresolvable SolverInstallPlan)
solveForTargets SolveResources
resources DepResolverParams -> DepResolverParams
forall a. a -> a
id [SolveTarget]
targets M (Either Unresolvable SolverInstallPlan)
-> (Either Unresolvable SolverInstallPlan -> M [a]) -> M [a]
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 ->
      [a] -> M [a]
forall a. a -> M a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ResolverPackage UnresolvedPkgLoc -> Maybe a)
-> [ResolverPackage UnresolvedPkgLoc] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ResolverPackage UnresolvedPkgLoc -> Maybe a
original (SolverInstallPlan -> [ResolverPackage UnresolvedPkgLoc]
topologicalOrder SolverInstallPlan
plan))
    Left Unresolvable
err -> do
      Text -> M ()
Log.error [exon|No plan for mutations: ##{err}|]
      pure [a]
mutations
  where
    original :: ResolverPackage UnresolvedPkgLoc -> Maybe a
original ResolverPackage UnresolvedPkgLoc
k = Map PackageName a
byName Map PackageName a -> PackageName -> Maybe a
forall k a. Ord k => Map k a -> k -> Maybe a
!? (ResolverPackage UnresolvedPkgLoc -> PackageId
forall a. ResolverPackage a -> PackageId
resolverPackageId ResolverPackage UnresolvedPkgLoc
k).name
    byName :: Map PackageName a
byName = [(PackageName, a)] -> Map PackageName a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(a -> PackageName
name a
m, a
m) | a
m <- [a]
mutations]
    targets :: [SolveTarget]
targets = [PackageName -> MutationConstraints -> SolveTarget
solveTarget (a -> PackageName
name a
m) MutationConstraints
forall a. Monoid a => a
mempty | a
m <- [a]
mutations]

sortMutations ::
  ∀ a .
  SolveResources ->
  [DepMutation a] ->
  M [DepMutation a]
sortMutations :: forall a. SolveResources -> [DepMutation a] -> M [DepMutation a]
sortMutations SolveResources
resources =
  SolveResources
-> (DepMutation a -> PackageName)
-> [DepMutation a]
-> M [DepMutation a]
forall a. SolveResources -> (a -> PackageName) -> [a] -> M [a]
sortDeps SolveResources
resources DepMutation a -> PackageName
forall {a}. DepMutation a -> PackageName
name
  where
    name :: DepMutation a -> PackageName
name DepMutation {package :: forall a. DepMutation a -> MutableDep
package = MutableDep PackageName
package} = PackageName
package