    -- | 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
    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) = 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
    $cshowsPrec :: Int -> RoughBuildList -> ShowS
    showsPrec :: Int -> RoughBuildList -> ShowS
    $cshow :: RoughBuildList -> String
    show :: RoughBuildList -> String
    $cshowList :: [RoughBuildList] -> ShowS
    showList :: [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 {f :: * -> *}.
    MonadState (Map PkgPath SemVer) f =>
    PkgPath -> f ()
    addPkg Set PkgPath
    roots) Map PkgPath SemVer
    forall a. Monoid a => a
    mempty
      where
        addPkg :: PkgPath -> f ()
    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 -> () -> f ()
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
          Just (SemVer
    v, [PkgPath]
    deps) -> do
            listed <- (Map PkgPath SemVer -> Bool) -> f Bool
    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
    gets ((Map PkgPath SemVer -> Bool) -> f Bool)
    -> (Map PkgPath SemVer -> Bool) -> f 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
            modify $ M.insert p v
            unless listed $ mapM_ addPkg 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 (m :: * -> *) a. Monad m => m a -> StateT RoughBuildList m a
    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 l <- StateT RoughBuildList (F PkgOp) RoughBuildList
    forall s (m :: * -> *). MonadState s m => m s
    get
          case M.lookup p 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 a. a -> StateT RoughBuildList (F PkgOp) a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
            -- No; add 'p' and its dependencies.
            Maybe (SemVer, [PkgPath])
    _ -> do
              PkgRevDeps p_deps <- PkgPath -> SemVer -> Maybe PkgPath -> SolveM PkgRevDeps
    getDeps PkgPath
    p SemVer
    v Maybe PkgPath
    maybe_h
              put $ RoughBuildList $ M.insert p (v, M.keys p_deps) l
              mapM_ add $ M.toList 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) =>
      CacheDir ->
      PkgRevDeps ->
      m BuildList
    solveDeps :: forall (m :: * -> *).
    MonadPkgRegistry m =>
    CacheDir -> PkgRevDeps -> m BuildList
    solveDeps CacheDir
    cachedir 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
    -> forall r. (RoughBuildList -> r) -> (PkgOp r -> r) -> r
    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 a. a -> m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure
          PkgOp (m RoughBuildList) -> m RoughBuildList
    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
          pinfo <- CacheDir -> PkgPath -> SemVer -> m (PkgRevInfo m)
    forall (m :: * -> *).
    MonadPkgRegistry m =>
    CacheDir -> PkgPath -> SemVer -> m (PkgRevInfo m)
    lookupPackageRev CacheDir
    cachedir PkgPath
    p SemVer
    v

          checkHash p v pinfo h

          d <- fmap pkgRevDeps . getManifest $ pkgRevGetManifest pinfo
          c d

        checkHash :: PkgPath -> SemVer -> PkgRevInfo m -> Maybe PkgPath -> f ()
    checkHash PkgPath
    _ SemVer
    _ PkgRevInfo m
    _ Maybe PkgPath
    Nothing = () -> f ()
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
        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 = () -> f ()
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()
          | Bool
    otherwise =
              String -> f ()
    forall a. String -> f a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> f ()) -> String -> f ()
    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
    -> forall r. (RoughBuildList -> r) -> (PkgOp r -> r) -> r
    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
          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
          c d