{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

-- | 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 qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text 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 :: (a -> b) -> PkgOp a -> PkgOp b
fmap a -> b
f (OpGetDeps PkgPath
p SemVer
v Maybe PkgPath
h PkgRevDeps -> a
c) = PkgPath -> SemVer -> Maybe PkgPath -> (PkgRevDeps -> b) -> PkgOp b
forall a.
PkgPath -> SemVer -> Maybe PkgPath -> (PkgRevDeps -> a) -> PkgOp a
OpGetDeps PkgPath
p SemVer
v Maybe PkgPath
h (a -> b
f (a -> b) -> (PkgRevDeps -> a) -> PkgRevDeps -> b
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
(Int -> RoughBuildList -> ShowS)
-> (RoughBuildList -> String)
-> ([RoughBuildList] -> ShowS)
-> Show RoughBuildList
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 Map PkgPath (SemVer, [PkgPath])
forall a. Monoid a => a
mempty

depRoots :: PkgRevDeps -> S.Set PkgPath
depRoots :: PkgRevDeps -> Set PkgPath
depRoots (PkgRevDeps Map PkgPath (SemVer, Maybe PkgPath)
m) = [PkgPath] -> Set PkgPath
forall a. Ord a => [a] -> Set a
S.fromList ([PkgPath] -> Set PkgPath) -> [PkgPath] -> Set PkgPath
forall a b. (a -> b) -> a -> b
$ Map PkgPath (SemVer, Maybe PkgPath) -> [PkgPath]
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 (Map PkgPath SemVer -> BuildList)
-> Map PkgPath SemVer -> BuildList
forall a b. (a -> b) -> a -> b
$ State (Map PkgPath SemVer) ()
-> Map PkgPath SemVer -> Map PkgPath SemVer
forall s a. State s a -> s -> s
execState ((PkgPath -> State (Map PkgPath SemVer) ())
-> Set PkgPath -> State (Map PkgPath SemVer) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PkgPath -> State (Map PkgPath SemVer) ()
forall (m :: * -> *).
MonadState (Map PkgPath SemVer) m =>
PkgPath -> m ()
addPkg Set PkgPath
roots) Map PkgPath SemVer
forall a. Monoid a => a
mempty
  where
    addPkg :: PkgPath -> m ()
addPkg PkgPath
p = case PkgPath
-> Map PkgPath (SemVer, [PkgPath]) -> Maybe (SemVer, [PkgPath])
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 -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just (SemVer
v, [PkgPath]
deps) -> do
        Bool
listed <- (Map PkgPath SemVer -> Bool) -> m Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Map PkgPath SemVer -> Bool) -> m Bool)
-> (Map PkgPath SemVer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ PkgPath -> Map PkgPath SemVer -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member PkgPath
p
        (Map PkgPath SemVer -> Map PkgPath SemVer) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map PkgPath SemVer -> Map PkgPath SemVer) -> m ())
-> (Map PkgPath SemVer -> Map PkgPath SemVer) -> m ()
forall a b. (a -> b) -> a -> b
$ PkgPath -> SemVer -> Map PkgPath SemVer -> Map PkgPath SemVer
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PkgPath
p SemVer
v
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
listed (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (PkgPath -> m ()) -> [PkgPath] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PkgPath -> m ()
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 = F PkgOp PkgRevDeps -> SolveM PkgRevDeps
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (F PkgOp PkgRevDeps -> SolveM PkgRevDeps)
-> F PkgOp PkgRevDeps -> SolveM PkgRevDeps
forall a b. (a -> b) -> a -> b
$ PkgOp PkgRevDeps -> F PkgOp PkgRevDeps
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (PkgOp PkgRevDeps -> F PkgOp PkgRevDeps)
-> PkgOp PkgRevDeps -> F PkgOp PkgRevDeps
forall a b. (a -> b) -> a -> b
$ PkgPath
-> SemVer
-> Maybe PkgPath
-> (PkgRevDeps -> PkgRevDeps)
-> PkgOp PkgRevDeps
forall a.
PkgPath -> SemVer -> Maybe PkgPath -> (PkgRevDeps -> a) -> PkgOp a
OpGetDeps PkgPath
p SemVer
v Maybe PkgPath
h PkgRevDeps -> PkgRevDeps
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) = ((PkgPath, (SemVer, Maybe PkgPath)) -> SolveM ())
-> [(PkgPath, (SemVer, Maybe PkgPath))] -> SolveM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (PkgPath, (SemVer, Maybe PkgPath)) -> SolveM ()
add ([(PkgPath, (SemVer, Maybe PkgPath))] -> SolveM ())
-> [(PkgPath, (SemVer, Maybe PkgPath))] -> SolveM ()
forall a b. (a -> b) -> a -> b
$ Map PkgPath (SemVer, Maybe PkgPath)
-> [(PkgPath, (SemVer, Maybe PkgPath))]
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 <- StateT RoughBuildList (F PkgOp) RoughBuildList
forall s (m :: * -> *). MonadState s m => m s
get
      case PkgPath
-> Map PkgPath (SemVer, [PkgPath]) -> Maybe (SemVer, [PkgPath])
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 SemVer -> SemVer -> Bool
forall a. Ord a => a -> a -> Bool
<= SemVer
cur_v -> () -> SolveM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- 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
          RoughBuildList -> SolveM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (RoughBuildList -> SolveM ()) -> RoughBuildList -> SolveM ()
forall a b. (a -> b) -> a -> b
$ Map PkgPath (SemVer, [PkgPath]) -> RoughBuildList
RoughBuildList (Map PkgPath (SemVer, [PkgPath]) -> RoughBuildList)
-> Map PkgPath (SemVer, [PkgPath]) -> RoughBuildList
forall a b. (a -> b) -> a -> b
$ PkgPath
-> (SemVer, [PkgPath])
-> Map PkgPath (SemVer, [PkgPath])
-> Map PkgPath (SemVer, [PkgPath])
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert PkgPath
p (SemVer
v, Map PkgPath (SemVer, Maybe PkgPath) -> [PkgPath]
forall k a. Map k a -> [k]
M.keys Map PkgPath (SemVer, Maybe PkgPath)
p_deps) Map PkgPath (SemVer, [PkgPath])
l
          ((PkgPath, (SemVer, Maybe PkgPath)) -> SolveM ())
-> [(PkgPath, (SemVer, Maybe PkgPath))] -> SolveM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (PkgPath, (SemVer, Maybe PkgPath)) -> SolveM ()
add ([(PkgPath, (SemVer, Maybe PkgPath))] -> SolveM ())
-> [(PkgPath, (SemVer, Maybe PkgPath))] -> SolveM ()
forall a b. (a -> b) -> a -> b
$ Map PkgPath (SemVer, Maybe PkgPath)
-> [(PkgPath, (SemVer, Maybe PkgPath))]
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 :: PkgRevDeps -> m BuildList
solveDeps PkgRevDeps
deps =
  Set PkgPath -> RoughBuildList -> BuildList
buildList (PkgRevDeps -> Set PkgPath
depRoots PkgRevDeps
deps)
    (RoughBuildList -> BuildList) -> m RoughBuildList -> m BuildList
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> F PkgOp RoughBuildList
-> (RoughBuildList -> m RoughBuildList)
-> (PkgOp (m RoughBuildList) -> m RoughBuildList)
-> m RoughBuildList
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF
      (SolveM () -> RoughBuildList -> F PkgOp RoughBuildList
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (PkgRevDeps -> SolveM ()
doSolveDeps PkgRevDeps
deps) RoughBuildList
emptyRoughBuildList)
      RoughBuildList -> m RoughBuildList
forall (m :: * -> *) a. Monad m => a -> m a
return
      PkgOp (m RoughBuildList) -> m RoughBuildList
forall (f :: * -> *) b. MonadPkgRegistry f => PkgOp (f b) -> f b
step
  where
    step :: PkgOp (f b) -> f b
step (OpGetDeps PkgPath
p SemVer
v Maybe PkgPath
h PkgRevDeps -> f b
c) = do
      PkgRevInfo f
pinfo <- PkgPath -> SemVer -> f (PkgRevInfo f)
forall (m :: * -> *).
MonadPkgRegistry m =>
PkgPath -> SemVer -> m (PkgRevInfo m)
lookupPackageRev PkgPath
p SemVer
v

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

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

    checkHash :: PkgPath -> SemVer -> PkgRevInfo m -> Maybe PkgPath -> m ()
checkHash PkgPath
_ SemVer
_ PkgRevInfo m
_ Maybe PkgPath
Nothing = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkHash PkgPath
p SemVer
v PkgRevInfo m
pinfo (Just PkgPath
h)
      | PkgPath
h PkgPath -> PkgPath -> Bool
forall a. Eq a => a -> a -> Bool
== PkgRevInfo m -> PkgPath
forall (m :: * -> *). PkgRevInfo m -> PkgPath
pkgRevCommit PkgRevInfo m
pinfo = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise =
        String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
          PkgPath -> String
T.unpack (PkgPath -> String) -> PkgPath -> String
forall a b. (a -> b) -> a -> b
$
            PkgPath
"Package " PkgPath -> PkgPath -> PkgPath
forall a. Semigroup a => a -> a -> a
<> PkgPath
p PkgPath -> PkgPath -> PkgPath
forall a. Semigroup a => a -> a -> a
<> PkgPath
" " PkgPath -> PkgPath -> PkgPath
forall a. Semigroup a => a -> a -> a
<> SemVer -> PkgPath
prettySemVer SemVer
v
              PkgPath -> PkgPath -> PkgPath
forall a. Semigroup a => a -> a -> a
<> PkgPath
" has commit hash "
              PkgPath -> PkgPath -> PkgPath
forall a. Semigroup a => a -> a -> a
<> PkgRevInfo m -> PkgPath
forall (m :: * -> *). PkgRevInfo m -> PkgPath
pkgRevCommit PkgRevInfo m
pinfo
              PkgPath -> PkgPath -> PkgPath
forall a. Semigroup a => a -> a -> a
<> PkgPath
", but expected "
              PkgPath -> PkgPath -> PkgPath
forall a. Semigroup a => a -> a -> a
<> PkgPath
h
              PkgPath -> PkgPath -> PkgPath
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)
    (RoughBuildList -> BuildList)
-> Either PkgPath RoughBuildList -> Either PkgPath BuildList
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> F PkgOp RoughBuildList
-> (RoughBuildList -> Either PkgPath RoughBuildList)
-> (PkgOp (Either PkgPath RoughBuildList)
    -> Either PkgPath RoughBuildList)
-> Either PkgPath RoughBuildList
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF
      (SolveM () -> RoughBuildList -> F PkgOp RoughBuildList
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (PkgRevDeps -> SolveM ()
doSolveDeps PkgRevDeps
deps) RoughBuildList
emptyRoughBuildList)
      RoughBuildList -> Either PkgPath RoughBuildList
forall a b. b -> Either a b
Right
      PkgOp (Either PkgPath RoughBuildList)
-> Either PkgPath RoughBuildList
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: " PkgPath -> PkgPath -> PkgPath
forall a. Semigroup a => a -> a -> a
<> PkgPath
p PkgPath -> PkgPath -> PkgPath
forall a. Semigroup a => a -> a -> a
<> PkgPath
"-" PkgPath -> PkgPath -> PkgPath
forall a. Semigroup a => a -> a -> a
<> SemVer -> PkgPath
prettySemVer SemVer
v
      PkgRevDeps
d <- Either PkgPath PkgRevDeps
-> (PkgRevDeps -> Either PkgPath PkgRevDeps)
-> Maybe PkgRevDeps
-> Either PkgPath PkgRevDeps
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PkgPath -> Either PkgPath PkgRevDeps
forall a b. a -> Either a b
Left PkgPath
errmsg) PkgRevDeps -> Either PkgPath PkgRevDeps
forall a b. b -> Either a b
Right (Maybe PkgRevDeps -> Either PkgPath PkgRevDeps)
-> Maybe PkgRevDeps -> Either PkgPath PkgRevDeps
forall a b. (a -> b) -> a -> b
$ (PkgPath, SemVer) -> PkgRevDepInfo -> Maybe PkgRevDeps
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