-- | Dependency solver
--
-- This is a relatively simple problem due to the choice of the
-- Minimum Package Version algorithm.  In fact, the only failure mode
-- is referencing an unknown package or revision.
module Futhark.Pkg.Solve
  ( solveDeps,
    solveDepsPure,
    PkgRevDepInfo,
  )
where

import Control.Monad.Free.Church
import Control.Monad.State
import Data.Map qualified as M
import Data.Set qualified as S
import Data.Text qualified as T
import Futhark.Pkg.Info
import Futhark.Pkg.Types
import Prelude

data PkgOp a = OpGetDeps PkgPath SemVer (Maybe T.Text) (PkgRevDeps -> a)

instance Functor PkgOp where
  fmap :: forall a b. (a -> b) -> PkgOp a -> PkgOp b
fmap a -> b
f (OpGetDeps PkgPath
p SemVer
v Maybe PkgPath
h PkgRevDeps -> a
c) = forall a.
PkgPath -> SemVer -> Maybe PkgPath -> (PkgRevDeps -> a) -> PkgOp a
OpGetDeps PkgPath
p SemVer
v Maybe PkgPath
h (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgRevDeps -> a
c)

-- | A rough build list is like a build list, but may contain packages
-- that are not reachable from the root.  Also contains the
-- dependencies of each package.
newtype RoughBuildList = RoughBuildList (M.Map PkgPath (SemVer, [PkgPath]))
  deriving (Int -> RoughBuildList -> ShowS
[RoughBuildList] -> ShowS
RoughBuildList -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RoughBuildList] -> ShowS
$cshowList :: [RoughBuildList] -> ShowS
show :: RoughBuildList -> String
$cshow :: RoughBuildList -> String
showsPrec :: Int -> RoughBuildList -> ShowS
$cshowsPrec :: Int -> RoughBuildList -> ShowS
Show)

emptyRoughBuildList :: RoughBuildList
emptyRoughBuildList :: RoughBuildList
emptyRoughBuildList = Map PkgPath (SemVer, [PkgPath]) -> RoughBuildList
RoughBuildList forall a. Monoid a => a
mempty

depRoots :: PkgRevDeps -> S.Set PkgPath
depRoots :: PkgRevDeps -> Set PkgPath
depRoots (PkgRevDeps Map PkgPath (SemVer, Maybe PkgPath)
m) = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys Map PkgPath (SemVer, Maybe PkgPath)
m

-- Construct a 'BuildList' from a 'RoughBuildList'.  This involves
-- pruning all packages that cannot be reached from the root.
buildList :: S.Set PkgPath -> RoughBuildList -> BuildList
buildList :: Set PkgPath -> RoughBuildList -> BuildList
buildList Set PkgPath
roots (RoughBuildList Map PkgPath (SemVer, [PkgPath])
pkgs) =
  Map PkgPath SemVer -> BuildList
BuildList forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> s
execState (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {f :: * -> *}.
MonadState (Map PkgPath SemVer) f =>
PkgPath -> f ()
addPkg Set PkgPath
roots) forall a. Monoid a => a
mempty
  where
    addPkg :: PkgPath -> f ()
addPkg PkgPath
p = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PkgPath
p Map PkgPath (SemVer, [PkgPath])
pkgs of
      Maybe (SemVer, [PkgPath])
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just (SemVer
v, [PkgPath]
deps) -> do
        Bool
listed <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Bool
M.member PkgPath
p
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PkgPath
p SemVer
v
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
listed forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PkgPath -> f ()
addPkg [PkgPath]
deps

type SolveM = StateT RoughBuildList (F PkgOp)

getDeps :: PkgPath -> SemVer -> Maybe T.Text -> SolveM PkgRevDeps
getDeps :: PkgPath -> SemVer -> Maybe PkgPath -> SolveM PkgRevDeps
getDeps PkgPath
p SemVer
v Maybe PkgPath
h = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF forall a b. (a -> b) -> a -> b
$ forall a.
PkgPath -> SemVer -> Maybe PkgPath -> (PkgRevDeps -> a) -> PkgOp a
OpGetDeps PkgPath
p SemVer
v Maybe PkgPath
h forall a. a -> a
id

-- | Given a list of immediate dependency minimum version constraints,
-- find dependency versions that fit, including transitive
-- dependencies.
doSolveDeps :: PkgRevDeps -> SolveM ()
doSolveDeps :: PkgRevDeps -> SolveM ()
doSolveDeps (PkgRevDeps Map PkgPath (SemVer, Maybe PkgPath)
deps) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (PkgPath, (SemVer, Maybe PkgPath)) -> SolveM ()
add forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map PkgPath (SemVer, Maybe PkgPath)
deps
  where
    add :: (PkgPath, (SemVer, Maybe PkgPath)) -> SolveM ()
add (PkgPath
p, (SemVer
v, Maybe PkgPath
maybe_h)) = do
      RoughBuildList Map PkgPath (SemVer, [PkgPath])
l <- forall s (m :: * -> *). MonadState s m => m s
get
      case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PkgPath
p Map PkgPath (SemVer, [PkgPath])
l of
        -- Already satisfied?
        Just (SemVer
cur_v, [PkgPath]
_) | SemVer
v forall a. Ord a => a -> a -> Bool
<= SemVer
cur_v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        -- No; add 'p' and its dependencies.
        Maybe (SemVer, [PkgPath])
_ -> do
          PkgRevDeps Map PkgPath (SemVer, Maybe PkgPath)
p_deps <- PkgPath -> SemVer -> Maybe PkgPath -> SolveM PkgRevDeps
getDeps PkgPath
p SemVer
v Maybe PkgPath
maybe_h
          forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ Map PkgPath (SemVer, [PkgPath]) -> RoughBuildList
RoughBuildList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PkgPath
p (SemVer
v, forall k a. Map k a -> [k]
M.keys Map PkgPath (SemVer, Maybe PkgPath)
p_deps) Map PkgPath (SemVer, [PkgPath])
l
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (PkgPath, (SemVer, Maybe PkgPath)) -> SolveM ()
add forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map PkgPath (SemVer, Maybe PkgPath)
p_deps

-- | Run the solver, producing both a package registry containing
-- a cache of the lookups performed, as well as a build list.
solveDeps ::
  MonadPkgRegistry m =>
  PkgRevDeps ->
  m BuildList
solveDeps :: forall (m :: * -> *).
MonadPkgRegistry m =>
PkgRevDeps -> m BuildList
solveDeps PkgRevDeps
deps =
  Set PkgPath -> RoughBuildList -> BuildList
buildList (PkgRevDeps -> Set PkgPath
depRoots PkgRevDeps
deps)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF
      (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (PkgRevDeps -> SolveM ()
doSolveDeps PkgRevDeps
deps) RoughBuildList
emptyRoughBuildList)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
      forall {m :: * -> *} {b}. MonadPkgRegistry m => PkgOp (m b) -> m b
step
  where
    step :: PkgOp (m b) -> m b
step (OpGetDeps PkgPath
p SemVer
v Maybe PkgPath
h PkgRevDeps -> m b
c) = do
      PkgRevInfo m
pinfo <- forall (m :: * -> *).
MonadPkgRegistry m =>
PkgPath -> SemVer -> m (PkgRevInfo m)
lookupPackageRev PkgPath
p SemVer
v

      forall {f :: * -> *} {m :: * -> *}.
MonadFail f =>
PkgPath -> SemVer -> PkgRevInfo m -> Maybe PkgPath -> f ()
checkHash PkgPath
p SemVer
v PkgRevInfo m
pinfo Maybe PkgPath
h

      PkgRevDeps
d <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PkgManifest -> PkgRevDeps
pkgRevDeps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). GetManifest m -> m PkgManifest
getManifest forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PkgRevInfo m -> GetManifest m
pkgRevGetManifest PkgRevInfo m
pinfo
      PkgRevDeps -> m b
c PkgRevDeps
d

    checkHash :: PkgPath -> SemVer -> PkgRevInfo m -> Maybe PkgPath -> f ()
checkHash PkgPath
_ SemVer
_ PkgRevInfo m
_ Maybe PkgPath
Nothing = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    checkHash PkgPath
p SemVer
v PkgRevInfo m
pinfo (Just PkgPath
h)
      | PkgPath
h forall a. Eq a => a -> a -> Bool
== forall (m :: * -> *). PkgRevInfo m -> PkgPath
pkgRevCommit PkgRevInfo m
pinfo = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise =
          forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
            PkgPath -> String
T.unpack forall a b. (a -> b) -> a -> b
$
              PkgPath
"Package "
                forall a. Semigroup a => a -> a -> a
<> PkgPath
p
                forall a. Semigroup a => a -> a -> a
<> PkgPath
" "
                forall a. Semigroup a => a -> a -> a
<> SemVer -> PkgPath
prettySemVer SemVer
v
                forall a. Semigroup a => a -> a -> a
<> PkgPath
" has commit hash "
                forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *). PkgRevInfo m -> PkgPath
pkgRevCommit PkgRevInfo m
pinfo
                forall a. Semigroup a => a -> a -> a
<> PkgPath
", but expected "
                forall a. Semigroup a => a -> a -> a
<> PkgPath
h
                forall a. Semigroup a => a -> a -> a
<> PkgPath
" from package manifest."

-- | A mapping of package revisions to the dependencies of that
-- package.  Can be considered a 'PkgRegistry' without the option of
-- obtaining more information from the Internet.  Probably useful only
-- for testing the solver.
type PkgRevDepInfo = M.Map (PkgPath, SemVer) PkgRevDeps

-- | Perform package resolution with only pre-known information.  This
-- is useful for testing.
solveDepsPure :: PkgRevDepInfo -> PkgRevDeps -> Either T.Text BuildList
solveDepsPure :: PkgRevDepInfo -> PkgRevDeps -> Either PkgPath BuildList
solveDepsPure PkgRevDepInfo
r PkgRevDeps
deps =
  Set PkgPath -> RoughBuildList -> BuildList
buildList (PkgRevDeps -> Set PkgPath
depRoots PkgRevDeps
deps)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF
      (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (PkgRevDeps -> SolveM ()
doSolveDeps PkgRevDeps
deps) RoughBuildList
emptyRoughBuildList)
      forall a b. b -> Either a b
Right
      forall {b}. PkgOp (Either PkgPath b) -> Either PkgPath b
step
  where
    step :: PkgOp (Either PkgPath b) -> Either PkgPath b
step (OpGetDeps PkgPath
p SemVer
v Maybe PkgPath
_ PkgRevDeps -> Either PkgPath b
c) = do
      let errmsg :: PkgPath
errmsg = PkgPath
"Unknown package/version: " forall a. Semigroup a => a -> a -> a
<> PkgPath
p forall a. Semigroup a => a -> a -> a
<> PkgPath
"-" forall a. Semigroup a => a -> a -> a
<> SemVer -> PkgPath
prettySemVer SemVer
v
      PkgRevDeps
d <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left PkgPath
errmsg) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (PkgPath
p, SemVer
v) PkgRevDepInfo
r
      PkgRevDeps -> Either PkgPath b
c PkgRevDeps
d