{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase    #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module    : Aura.Dependencies
-- Copyright : (c) Colin Woodbury, 2012 - 2020
-- License   : GPL3
-- Maintainer: Colin Woodbury <colin@fosskers.ca>
--
-- Library for handling package dependencies and version conflicts.

module Aura.Dependencies ( resolveDeps ) where

import           Algebra.Graph.AdjacencyMap
import           Algebra.Graph.AdjacencyMap.Algorithm (scc)
import qualified Algebra.Graph.NonEmpty.AdjacencyMap as NAM
import           Algebra.Graph.ToGraph (isAcyclic)
import           Aura.Core
import           Aura.IO
import           Aura.Languages
import           Aura.Settings
import           Aura.Types
import           Aura.Utils
import           Data.Versions hiding (Lens')
import           RIO
import           RIO.Lens (each)
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NEL
import qualified RIO.Set as S
import qualified RIO.Text as T

---

-- | The results of dependency resolution.
data Resolution = Resolution
  { Resolution -> Map PkgName Package
toInstall :: !(Map PkgName Package)
  , Resolution -> Set PkgName
satisfied :: !(Set PkgName) }
  deriving ((forall x. Resolution -> Rep Resolution x)
-> (forall x. Rep Resolution x -> Resolution) -> Generic Resolution
forall x. Rep Resolution x -> Resolution
forall x. Resolution -> Rep Resolution x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Resolution x -> Resolution
$cfrom :: forall x. Resolution -> Rep Resolution x
Generic)

toInstallL :: Lens' Resolution (Map PkgName Package)
toInstallL :: (Map PkgName Package -> f (Map PkgName Package))
-> Resolution -> f Resolution
toInstallL Map PkgName Package -> f (Map PkgName Package)
f Resolution
r = (\Map PkgName Package
m -> Resolution
r { toInstall :: Map PkgName Package
toInstall = Map PkgName Package
m }) (Map PkgName Package -> Resolution)
-> f (Map PkgName Package) -> f Resolution
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map PkgName Package -> f (Map PkgName Package)
f (Resolution -> Map PkgName Package
toInstall Resolution
r)

satisfiedL :: Lens' Resolution (Set PkgName)
satisfiedL :: (Set PkgName -> f (Set PkgName)) -> Resolution -> f Resolution
satisfiedL Set PkgName -> f (Set PkgName)
f Resolution
r = (\Set PkgName
s -> Resolution
r { satisfied :: Set PkgName
satisfied = Set PkgName
s }) (Set PkgName -> Resolution) -> f (Set PkgName) -> f Resolution
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set PkgName -> f (Set PkgName)
f (Resolution -> Set PkgName
satisfied Resolution
r)

-- | Given some `Package`s, determine its full dependency graph.
-- The graph is collapsed into layers of packages which are not
-- interdependent, and thus can be built and installed as a group.
--
-- Deeper layers of the result list (generally) depend on the previous layers.
resolveDeps :: Repository -> NonEmpty Package -> RIO Env (NonEmpty (NonEmpty Package))
resolveDeps :: Repository
-> NonEmpty Package -> RIO Env (NonEmpty (NonEmpty Package))
resolveDeps Repository
repo NonEmpty Package
ps = do
  Utf8Builder -> RIO Env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"resolveDeps: Entered."
  Settings
ss <- (Env -> Settings) -> RIO Env Settings
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Settings
settings
  Either Failure Resolution
res <- IO (Either Failure Resolution)
-> RIO Env (Either Failure Resolution)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Resolution -> Either Failure Resolution
forall a b. b -> Either a b
Right (Resolution -> Either Failure Resolution)
-> IO Resolution -> IO (Either Failure Resolution)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Repository -> NonEmpty Package -> IO Resolution
resolveDeps' Settings
ss Repository
repo NonEmpty Package
ps) RIO Env (Either Failure Resolution)
-> (SomeException -> RIO Env (Either Failure Resolution))
-> RIO Env (Either Failure Resolution)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` SomeException -> RIO Env (Either Failure Resolution)
forall a. SomeException -> RIO Env (Either Failure a)
handleError
  Resolution Map PkgName Package
m Set PkgName
s <- (Failure -> RIO Env Resolution)
-> (Resolution -> RIO Env Resolution)
-> Either Failure Resolution
-> RIO Env Resolution
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Failure -> RIO Env Resolution
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM Resolution -> RIO Env Resolution
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either Failure Resolution
res
  Utf8Builder -> RIO Env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"resolveDeps: Successful recursive dep lookup."
  Bool -> RIO Env () -> RIO Env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (NonEmpty Package -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty Package
ps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Map PkgName Package -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Map PkgName Package
m) (RIO Env () -> RIO Env ()) -> RIO Env () -> RIO Env ()
forall a b. (a -> b) -> a -> b
$ Text -> RIO Env ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putText Text
"\n"
  let de :: [DepError]
de = Settings -> Map PkgName Package -> Set PkgName -> [DepError]
conflicts Settings
ss Map PkgName Package
m Set PkgName
s
  Bool -> RIO Env () -> RIO Env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([DepError] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DepError]
de) (RIO Env () -> RIO Env ())
-> ((Language -> Doc AnsiStyle) -> RIO Env ())
-> (Language -> Doc AnsiStyle)
-> RIO Env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure -> RIO Env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Failure -> RIO Env ())
-> ((Language -> Doc AnsiStyle) -> Failure)
-> (Language -> Doc AnsiStyle)
-> RIO Env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailMsg -> Failure
Failure (FailMsg -> Failure)
-> ((Language -> Doc AnsiStyle) -> FailMsg)
-> (Language -> Doc AnsiStyle)
-> Failure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Language -> Doc AnsiStyle) -> FailMsg
FailMsg ((Language -> Doc AnsiStyle) -> RIO Env ())
-> (Language -> Doc AnsiStyle) -> RIO Env ()
forall a b. (a -> b) -> a -> b
$ [DepError] -> Language -> Doc AnsiStyle
missingPkg_2 [DepError]
de
  (Failure -> RIO Env (NonEmpty (NonEmpty Package)))
-> (NonEmpty (NonEmpty Package)
    -> RIO Env (NonEmpty (NonEmpty Package)))
-> Either Failure (NonEmpty (NonEmpty Package))
-> RIO Env (NonEmpty (NonEmpty Package))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Failure -> RIO Env (NonEmpty (NonEmpty Package))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM NonEmpty (NonEmpty Package)
-> RIO Env (NonEmpty (NonEmpty Package))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Failure (NonEmpty (NonEmpty Package))
 -> RIO Env (NonEmpty (NonEmpty Package)))
-> Either Failure (NonEmpty (NonEmpty Package))
-> RIO Env (NonEmpty (NonEmpty Package))
forall a b. (a -> b) -> a -> b
$ Map PkgName Package -> Either Failure (NonEmpty (NonEmpty Package))
sortInstall Map PkgName Package
m
  where
    handleError :: SomeException -> RIO Env (Either Failure a)
    handleError :: SomeException -> RIO Env (Either Failure a)
handleError SomeException
e = Either Failure a -> RIO Env (Either Failure a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Failure a -> RIO Env (Either Failure a))
-> (Text -> Either Failure a) -> Text -> RIO Env (Either Failure a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure -> Either Failure a
forall a b. a -> Either a b
Left (Failure -> Either Failure a)
-> (Text -> Failure) -> Text -> Either Failure a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailMsg -> Failure
Failure (FailMsg -> Failure) -> (Text -> FailMsg) -> Text -> Failure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Language -> Doc AnsiStyle) -> FailMsg
FailMsg ((Language -> Doc AnsiStyle) -> FailMsg)
-> (Text -> Language -> Doc AnsiStyle) -> Text -> FailMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Language -> Doc AnsiStyle
dependencyLookup_1 (Text -> RIO Env (Either Failure a))
-> Text -> RIO Env (Either Failure a)
forall a b. (a -> b) -> a -> b
$ SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
e

-- | Solve dependencies for a set of `Package`s assumed to not be
-- installed/satisfied.
resolveDeps' :: Settings -> Repository -> NonEmpty Package -> IO Resolution
resolveDeps' :: Settings -> Repository -> NonEmpty Package -> IO Resolution
resolveDeps' Settings
ss Repository
repo NonEmpty Package
ps = Resolution -> NonEmpty Package -> IO Resolution
resolve (Map PkgName Package -> Set PkgName -> Resolution
Resolution Map PkgName Package
forall a. Monoid a => a
mempty Set PkgName
forall a. Monoid a => a
mempty) NonEmpty Package
ps
  where
    -- | Only searches for packages that we haven't checked yet.
    resolve :: Resolution -> NonEmpty Package -> IO Resolution
    resolve :: Resolution -> NonEmpty Package -> IO Resolution
resolve r :: Resolution
r@(Resolution Map PkgName Package
m Set PkgName
_) NonEmpty Package
xs = IO Resolution
-> Maybe (NonEmpty Package)
-> (NonEmpty Package -> IO Resolution)
-> IO Resolution
forall b a. b -> Maybe a -> (a -> b) -> b
maybe' (Resolution -> IO Resolution
forall (f :: * -> *) a. Applicative f => a -> f a
pure Resolution
r) ([Package] -> Maybe (NonEmpty Package)
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty [Package]
goods) ((NonEmpty Package -> IO Resolution) -> IO Resolution)
-> (NonEmpty Package -> IO Resolution) -> IO Resolution
forall a b. (a -> b) -> a -> b
$ \NonEmpty Package
goods' -> do
      let m' :: Map PkgName Package
m' = [(PkgName, Package)] -> Map PkgName Package
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(PkgName, Package)] -> Map PkgName Package)
-> ([Package] -> [(PkgName, Package)])
-> [Package]
-> Map PkgName Package
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Package -> (PkgName, Package))
-> [Package] -> [(PkgName, Package)]
forall a b. (a -> b) -> [a] -> [b]
map (Package -> PkgName
pname (Package -> PkgName)
-> (Package -> Package) -> Package -> (PkgName, Package)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Package -> Package
forall a. a -> a
id) ([Package] -> Map PkgName Package)
-> [Package] -> Map PkgName Package
forall a b. (a -> b) -> a -> b
$ NonEmpty Package -> [Package]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Package
goods'
          r' :: Resolution
r' = Resolution
r Resolution -> (Resolution -> Resolution) -> Resolution
forall a b. a -> (a -> b) -> b
& (Map PkgName Package -> Identity (Map PkgName Package))
-> Resolution -> Identity Resolution
Lens' Resolution (Map PkgName Package)
toInstallL ((Map PkgName Package -> Identity (Map PkgName Package))
 -> Resolution -> Identity Resolution)
-> (Map PkgName Package -> Map PkgName Package)
-> Resolution
-> Resolution
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Map PkgName Package -> Map PkgName Package -> Map PkgName Package
forall a. Semigroup a => a -> a -> a
<> Map PkgName Package
m')
      (NonEmpty Prebuilt -> IO Resolution)
-> (NonEmpty Buildable -> IO Resolution)
-> (NonEmpty Prebuilt -> NonEmpty Buildable -> IO Resolution)
-> These (NonEmpty Prebuilt) (NonEmpty Buildable)
-> IO Resolution
forall a t b.
(a -> t) -> (b -> t) -> (a -> b -> t) -> These a b -> t
these (IO Resolution -> NonEmpty Prebuilt -> IO Resolution
forall a b. a -> b -> a
const (IO Resolution -> NonEmpty Prebuilt -> IO Resolution)
-> IO Resolution -> NonEmpty Prebuilt -> IO Resolution
forall a b. (a -> b) -> a -> b
$ Resolution -> IO Resolution
forall (f :: * -> *) a. Applicative f => a -> f a
pure Resolution
r') (Resolution -> NonEmpty Buildable -> IO Resolution
satisfy Resolution
r') ((NonEmpty Buildable -> IO Resolution)
-> NonEmpty Prebuilt -> NonEmpty Buildable -> IO Resolution
forall a b. a -> b -> a
const ((NonEmpty Buildable -> IO Resolution)
 -> NonEmpty Prebuilt -> NonEmpty Buildable -> IO Resolution)
-> (NonEmpty Buildable -> IO Resolution)
-> NonEmpty Prebuilt
-> NonEmpty Buildable
-> IO Resolution
forall a b. (a -> b) -> a -> b
$ Resolution -> NonEmpty Buildable -> IO Resolution
satisfy Resolution
r') (These (NonEmpty Prebuilt) (NonEmpty Buildable) -> IO Resolution)
-> These (NonEmpty Prebuilt) (NonEmpty Buildable) -> IO Resolution
forall a b. (a -> b) -> a -> b
$ NonEmpty Package -> These (NonEmpty Prebuilt) (NonEmpty Buildable)
dividePkgs NonEmpty Package
goods'
      where
        goods :: [Package]
        goods :: [Package]
goods = (Package -> Bool) -> NonEmpty Package -> [Package]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NEL.filter (\Package
p -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Package -> PkgName
pname Package
p PkgName -> Map PkgName Package -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map PkgName Package
m) NonEmpty Package
xs

    -- | All dependencies from all potential `Buildable`s.
    allDeps :: NonEmpty Buildable -> Set Dep
    allDeps :: NonEmpty Buildable -> Set Dep
allDeps = (Buildable -> Set Dep) -> NonEmpty Buildable -> Set Dep
forall m a. Semigroup m => (a -> m) -> NonEmpty a -> m
foldMap1 ([Dep] -> Set Dep
forall a. Ord a => [a] -> Set a
S.fromList ([Dep] -> Set Dep) -> (Buildable -> [Dep]) -> Buildable -> Set Dep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Buildable -> Getting (Endo [Dep]) Buildable Dep -> [Dep]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (Buildable -> [Dep]) -> SimpleGetter Buildable [Dep]
forall s a. (s -> a) -> SimpleGetter s a
to Buildable -> [Dep]
bDeps Getting (Endo [Dep]) Buildable [Dep]
-> ((Dep -> Const (Endo [Dep]) Dep)
    -> [Dep] -> Const (Endo [Dep]) [Dep])
-> Getting (Endo [Dep]) Buildable Dep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dep -> Const (Endo [Dep]) Dep)
-> [Dep] -> Const (Endo [Dep]) [Dep]
forall s t a b. Each s t a b => Traversal s t a b
each))

    -- | Deps which are not yet queued for install.
    freshDeps :: Resolution -> Set Dep -> Set Dep
    freshDeps :: Resolution -> Set Dep -> Set Dep
freshDeps (Resolution Map PkgName Package
m Set PkgName
s) = (Dep -> Bool) -> Set Dep -> Set Dep
forall a. (a -> Bool) -> Set a -> Set a
S.filter Dep -> Bool
f
      where
        f :: Dep -> Bool
        f :: Dep -> Bool
f Dep
d = let n :: PkgName
n = Dep -> PkgName
dName Dep
d in Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PkgName -> Map PkgName Package -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member PkgName
n Map PkgName Package
m Bool -> Bool -> Bool
|| PkgName -> Set PkgName -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member PkgName
n Set PkgName
s

    -- | Consider only "unsatisfied" deps.
    satisfy :: Resolution -> NonEmpty Buildable -> IO Resolution
    satisfy :: Resolution -> NonEmpty Buildable -> IO Resolution
satisfy Resolution
r NonEmpty Buildable
bs = IO Resolution
-> Maybe (NonEmpty Dep)
-> (NonEmpty Dep -> IO Resolution)
-> IO Resolution
forall b a. b -> Maybe a -> (a -> b) -> b
maybe' (Resolution -> IO Resolution
forall (f :: * -> *) a. Applicative f => a -> f a
pure Resolution
r) (Set Dep -> Maybe (NonEmpty Dep)
forall a. Set a -> Maybe (NonEmpty a)
nes (Set Dep -> Maybe (NonEmpty Dep))
-> (Set Dep -> Set Dep) -> Set Dep -> Maybe (NonEmpty Dep)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resolution -> Set Dep -> Set Dep
freshDeps Resolution
r (Set Dep -> Maybe (NonEmpty Dep))
-> Set Dep -> Maybe (NonEmpty Dep)
forall a b. (a -> b) -> a -> b
$ NonEmpty Buildable -> Set Dep
allDeps NonEmpty Buildable
bs) ((NonEmpty Dep -> IO Resolution) -> IO Resolution)
-> (NonEmpty Dep -> IO Resolution) -> IO Resolution
forall a b. (a -> b) -> a -> b
$
      Environment -> NonEmpty Dep -> IO (These Unsatisfied Satisfied)
areSatisfied (Settings -> Environment
envOf Settings
ss) (NonEmpty Dep -> IO (These Unsatisfied Satisfied))
-> (These Unsatisfied Satisfied -> IO Resolution)
-> NonEmpty Dep
-> IO Resolution
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Unsatisfied -> IO Resolution)
-> (Satisfied -> IO Resolution)
-> (Unsatisfied -> Satisfied -> IO Resolution)
-> These Unsatisfied Satisfied
-> IO Resolution
forall a t b.
(a -> t) -> (b -> t) -> (a -> b -> t) -> These a b -> t
these (Resolution -> Unsatisfied -> IO Resolution
lookups Resolution
r) (Resolution -> IO Resolution
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resolution -> IO Resolution)
-> (Satisfied -> Resolution) -> Satisfied -> IO Resolution
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Satisfied -> Resolution
r') (\Unsatisfied
uns Satisfied
sat -> Resolution -> Unsatisfied -> IO Resolution
lookups (Satisfied -> Resolution
r' Satisfied
sat) Unsatisfied
uns)
      where
        r' :: Satisfied -> Resolution
        r' :: Satisfied -> Resolution
r' (Satisfied NonEmpty Dep
sat) = Resolution
r Resolution -> (Resolution -> Resolution) -> Resolution
forall a b. a -> (a -> b) -> b
& (Set PkgName -> Identity (Set PkgName))
-> Resolution -> Identity Resolution
Lens' Resolution (Set PkgName)
satisfiedL ((Set PkgName -> Identity (Set PkgName))
 -> Resolution -> Identity Resolution)
-> (Set PkgName -> Set PkgName) -> Resolution -> Resolution
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Set PkgName -> Set PkgName -> Set PkgName
forall a. Semigroup a => a -> a -> a
<> NonEmpty Dep -> Set PkgName
f NonEmpty Dep
sat)

        -- | Unique names of some dependencies.
        f :: NonEmpty Dep -> Set PkgName
        f :: NonEmpty Dep -> Set PkgName
f = [PkgName] -> Set PkgName
forall a. Ord a => [a] -> Set a
S.fromList ([PkgName] -> Set PkgName)
-> (NonEmpty Dep -> [PkgName]) -> NonEmpty Dep -> Set PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PkgName -> [PkgName]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty PkgName -> [PkgName])
-> (NonEmpty Dep -> NonEmpty PkgName) -> NonEmpty Dep -> [PkgName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dep -> PkgName) -> NonEmpty Dep -> NonEmpty PkgName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NEL.map Dep -> PkgName
dName

    -- | Lookup unsatisfied deps and recurse the entire lookup process.
    lookups :: Resolution -> Unsatisfied -> IO Resolution
    lookups :: Resolution -> Unsatisfied -> IO Resolution
lookups Resolution
r (Unsatisfied NonEmpty Dep
ds) = do
      let names :: NonEmpty PkgName
names = (Dep -> PkgName) -> NonEmpty Dep -> NonEmpty PkgName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NEL.map Dep -> PkgName
dName NonEmpty Dep
ds
      Repository
-> Settings
-> NonEmpty PkgName
-> IO (Maybe (Set PkgName, Set Package))
repoLookup Repository
repo Settings
ss NonEmpty PkgName
names IO (Maybe (Set PkgName, Set Package))
-> (Maybe (Set PkgName, Set Package) -> IO Resolution)
-> IO Resolution
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (Set PkgName, Set Package)
Nothing -> String -> IO Resolution
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Unexpected AUR Connection Error"
        Just (Set PkgName
bads, Set Package
could) -> case Set Package -> Maybe (NonEmpty Package)
forall a. Set a -> Maybe (NonEmpty a)
nes Set Package
could of
          Maybe (NonEmpty Package)
Nothing    -> do
            let badNames :: String
badNames = [String] -> String
unwords ([String] -> String)
-> ([PkgName] -> [String]) -> [PkgName] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PkgName -> String) -> [PkgName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String) -> (PkgName -> Text) -> PkgName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgName -> Text
pnName) ([PkgName] -> String) -> [PkgName] -> String
forall a b. (a -> b) -> a -> b
$ Set PkgName -> [PkgName]
forall a. Set a -> [a]
S.toList Set PkgName
bads
            String -> IO Resolution
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> IO Resolution) -> String -> IO Resolution
forall a b. (a -> b) -> a -> b
$ String
"Non-existant deps: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
badNames
          Just NonEmpty Package
goods -> Resolution -> NonEmpty Package -> IO Resolution
resolve Resolution
r NonEmpty Package
goods

conflicts :: Settings -> Map PkgName Package -> Set PkgName -> [DepError]
conflicts :: Settings -> Map PkgName Package -> Set PkgName -> [DepError]
conflicts Settings
ss Map PkgName Package
m Set PkgName
s = (Package -> [DepError]) -> Map PkgName Package -> [DepError]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Package -> [DepError]
f Map PkgName Package
m
  where
    pm :: Map PkgName Package
    pm :: Map PkgName Package
pm = [(PkgName, Package)] -> Map PkgName Package
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(PkgName, Package)] -> Map PkgName Package)
-> [(PkgName, Package)] -> Map PkgName Package
forall a b. (a -> b) -> a -> b
$ (Package -> (PkgName, Package))
-> [Package] -> [(PkgName, Package)]
forall a b. (a -> b) -> [a] -> [b]
map (\Package
p -> (Provides -> PkgName
provides (Provides -> PkgName) -> Provides -> PkgName
forall a b. (a -> b) -> a -> b
$ Package -> Provides
pprov Package
p, Package
p)) ([Package] -> [(PkgName, Package)])
-> [Package] -> [(PkgName, Package)]
forall a b. (a -> b) -> a -> b
$ Map PkgName Package -> [Package]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Map PkgName Package
m

    f :: Package -> [DepError]
    f :: Package -> [DepError]
f (FromRepo Prebuilt
_) = []
    f (FromAUR Buildable
b)  = ((Dep -> Maybe DepError) -> [Dep] -> [DepError])
-> [Dep] -> (Dep -> Maybe DepError) -> [DepError]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Dep -> Maybe DepError) -> [Dep] -> [DepError]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Buildable -> [Dep]
bDeps Buildable
b) ((Dep -> Maybe DepError) -> [DepError])
-> (Dep -> Maybe DepError) -> [DepError]
forall a b. (a -> b) -> a -> b
$ \Dep
d ->
      let dn :: PkgName
dn = Dep -> PkgName
dName Dep
d
      -- Don't do conflict checks for deps which are known to be satisfied on
      -- the system.
      in if PkgName -> Set PkgName -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member PkgName
dn Set PkgName
s then Maybe DepError
forall a. Maybe a
Nothing
         else case PkgName -> Map PkgName Package -> Maybe Package
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PkgName
dn Map PkgName Package
m Maybe Package -> Maybe Package -> Maybe Package
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PkgName -> Map PkgName Package -> Maybe Package
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup PkgName
dn Map PkgName Package
pm of
                Maybe Package
Nothing -> DepError -> Maybe DepError
forall a. a -> Maybe a
Just (DepError -> Maybe DepError)
-> (PkgName -> DepError) -> PkgName -> Maybe DepError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgName -> PkgName -> DepError
NonExistant PkgName
dn (PkgName -> Maybe DepError) -> PkgName -> Maybe DepError
forall a b. (a -> b) -> a -> b
$ Buildable -> PkgName
bName Buildable
b
                Just Package
p  -> Settings -> PkgName -> Package -> Dep -> Maybe DepError
realPkgConflicts Settings
ss (Buildable -> PkgName
bName Buildable
b) Package
p Dep
d

sortInstall :: Map PkgName Package -> Either Failure (NonEmpty (NonEmpty Package))
sortInstall :: Map PkgName Package -> Either Failure (NonEmpty (NonEmpty Package))
sortInstall Map PkgName Package
m = case AdjacencyMap Package -> [AdjacencyMap Package]
forall a. Ord a => AdjacencyMap a -> [AdjacencyMap a]
cycles AdjacencyMap Package
depGraph of
  [] -> Failure
-> Maybe (NonEmpty (NonEmpty Package))
-> Either Failure (NonEmpty (NonEmpty Package))
forall a b. a -> Maybe b -> Either a b
note (FailMsg -> Failure
Failure (FailMsg -> Failure) -> FailMsg -> Failure
forall a b. (a -> b) -> a -> b
$ (Language -> Doc AnsiStyle) -> FailMsg
FailMsg Language -> Doc AnsiStyle
missingPkg_3) (Maybe (NonEmpty (NonEmpty Package))
 -> Either Failure (NonEmpty (NonEmpty Package)))
-> ([Set Package] -> Maybe (NonEmpty (NonEmpty Package)))
-> [Set Package]
-> Either Failure (NonEmpty (NonEmpty Package))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NonEmpty Package] -> Maybe (NonEmpty (NonEmpty Package))
forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty ([NonEmpty Package] -> Maybe (NonEmpty (NonEmpty Package)))
-> ([Set Package] -> [NonEmpty Package])
-> [Set Package]
-> Maybe (NonEmpty (NonEmpty Package))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Package -> Maybe (NonEmpty Package))
-> [Set Package] -> [NonEmpty Package]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Set Package -> Maybe (NonEmpty Package)
forall a. Set a -> Maybe (NonEmpty a)
nes ([Set Package] -> Either Failure (NonEmpty (NonEmpty Package)))
-> [Set Package] -> Either Failure (NonEmpty (NonEmpty Package))
forall a b. (a -> b) -> a -> b
$ AdjacencyMap Package -> [Set Package]
forall a. Ord a => AdjacencyMap a -> [Set a]
batch AdjacencyMap Package
depGraph
  [AdjacencyMap Package]
cs -> Failure -> Either Failure (NonEmpty (NonEmpty Package))
forall a b. a -> Either a b
Left (Failure -> Either Failure (NonEmpty (NonEmpty Package)))
-> ([NonEmpty PkgName] -> Failure)
-> [NonEmpty PkgName]
-> Either Failure (NonEmpty (NonEmpty Package))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailMsg -> Failure
Failure (FailMsg -> Failure)
-> ([NonEmpty PkgName] -> FailMsg) -> [NonEmpty PkgName] -> Failure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Language -> Doc AnsiStyle) -> FailMsg
FailMsg ((Language -> Doc AnsiStyle) -> FailMsg)
-> ([NonEmpty PkgName] -> Language -> Doc AnsiStyle)
-> [NonEmpty PkgName]
-> FailMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NonEmpty PkgName] -> Language -> Doc AnsiStyle
missingPkg_4 ([NonEmpty PkgName]
 -> Either Failure (NonEmpty (NonEmpty Package)))
-> [NonEmpty PkgName]
-> Either Failure (NonEmpty (NonEmpty Package))
forall a b. (a -> b) -> a -> b
$ (AdjacencyMap Package -> NonEmpty PkgName)
-> [AdjacencyMap Package] -> [NonEmpty PkgName]
forall a b. (a -> b) -> [a] -> [b]
map ((Package -> PkgName) -> NonEmpty Package -> NonEmpty PkgName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NEL.map Package -> PkgName
pname (NonEmpty Package -> NonEmpty PkgName)
-> (AdjacencyMap Package -> NonEmpty Package)
-> AdjacencyMap Package
-> NonEmpty PkgName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap Package -> NonEmpty Package
forall a. AdjacencyMap a -> NonEmpty a
NAM.vertexList1) [AdjacencyMap Package]
cs
  where
    f :: Package -> [(Package, Package)]
    f :: Package -> [(Package, Package)]
f (FromRepo Prebuilt
_)  = []
    f p :: Package
p@(FromAUR Buildable
b) = (Dep -> Maybe (Package, Package)) -> [Dep] -> [(Package, Package)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Dep
d -> (Package -> (Package, Package))
-> Maybe Package -> Maybe (Package, Package)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Package
p,) (Maybe Package -> Maybe (Package, Package))
-> Maybe Package -> Maybe (Package, Package)
forall a b. (a -> b) -> a -> b
$ Dep -> PkgName
dName Dep
d PkgName -> Map PkgName Package -> Maybe Package
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map PkgName Package
m)
      ([Dep] -> [(Package, Package)]) -> [Dep] -> [(Package, Package)]
forall a b. (a -> b) -> a -> b
$ Buildable -> [Dep]
bDeps Buildable
b -- TODO handle "provides"?

    depGraph :: AdjacencyMap Package
depGraph  = AdjacencyMap Package
-> AdjacencyMap Package -> AdjacencyMap Package
forall a.
Ord a =>
AdjacencyMap a -> AdjacencyMap a -> AdjacencyMap a
overlay AdjacencyMap Package
connected AdjacencyMap Package
singles
    elems :: [Package]
elems     = Map PkgName Package -> [Package]
forall k a. Map k a -> [a]
M.elems Map PkgName Package
m
    connected :: AdjacencyMap Package
connected = [(Package, Package)] -> AdjacencyMap Package
forall a. Ord a => [(a, a)] -> AdjacencyMap a
edges ([(Package, Package)] -> AdjacencyMap Package)
-> [(Package, Package)] -> AdjacencyMap Package
forall a b. (a -> b) -> a -> b
$ (Package -> [(Package, Package)])
-> [Package] -> [(Package, Package)]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Package -> [(Package, Package)]
f [Package]
elems
    singles :: AdjacencyMap Package
singles   = [AdjacencyMap Package] -> AdjacencyMap Package
forall a. Ord a => [AdjacencyMap a] -> AdjacencyMap a
overlays ([AdjacencyMap Package] -> AdjacencyMap Package)
-> [AdjacencyMap Package] -> AdjacencyMap Package
forall a b. (a -> b) -> a -> b
$ (Package -> AdjacencyMap Package)
-> [Package] -> [AdjacencyMap Package]
forall a b. (a -> b) -> [a] -> [b]
map Package -> AdjacencyMap Package
forall a. a -> AdjacencyMap a
vertex [Package]
elems

cycles :: Ord a => AdjacencyMap a -> [NAM.AdjacencyMap a]
cycles :: AdjacencyMap a -> [AdjacencyMap a]
cycles = (AdjacencyMap a -> Bool) -> [AdjacencyMap a] -> [AdjacencyMap a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (AdjacencyMap a -> Bool) -> AdjacencyMap a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a -> Bool
forall t. (ToGraph t, Ord (ToVertex t)) => t -> Bool
isAcyclic) ([AdjacencyMap a] -> [AdjacencyMap a])
-> (AdjacencyMap a -> [AdjacencyMap a])
-> AdjacencyMap a
-> [AdjacencyMap a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap (AdjacencyMap a) -> [AdjacencyMap a]
forall a. AdjacencyMap a -> [a]
vertexList (AdjacencyMap (AdjacencyMap a) -> [AdjacencyMap a])
-> (AdjacencyMap a -> AdjacencyMap (AdjacencyMap a))
-> AdjacencyMap a
-> [AdjacencyMap a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyMap a -> AdjacencyMap (AdjacencyMap a)
forall a. Ord a => AdjacencyMap a -> AdjacencyMap (AdjacencyMap a)
scc

-- | Find the vertices that have no dependencies.
-- O(n) complexity.
leaves :: Ord a => AdjacencyMap a -> Set a
leaves :: AdjacencyMap a -> Set a
leaves AdjacencyMap a
x = (a -> Bool) -> Set a -> Set a
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set a -> Bool) -> (a -> Set a) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> AdjacencyMap a -> Set a) -> AdjacencyMap a -> a -> Set a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> AdjacencyMap a -> Set a
forall a. Ord a => a -> AdjacencyMap a -> Set a
postSet AdjacencyMap a
x) (Set a -> Set a) -> Set a -> Set a
forall a b. (a -> b) -> a -> b
$ AdjacencyMap a -> Set a
forall a. AdjacencyMap a -> Set a
vertexSet AdjacencyMap a
x

-- | Split a graph into batches of mutually independent vertices.
-- Probably O(m * n * log(n)) complexity.
batch :: Ord a => AdjacencyMap a -> [Set a]
batch :: AdjacencyMap a -> [Set a]
batch AdjacencyMap a
g | AdjacencyMap a -> Bool
forall a. AdjacencyMap a -> Bool
isEmpty AdjacencyMap a
g = []
        | Bool
otherwise = Set a
ls Set a -> [Set a] -> [Set a]
forall a. a -> [a] -> [a]
: AdjacencyMap a -> [Set a]
forall a. Ord a => AdjacencyMap a -> [Set a]
batch ((a -> Bool) -> AdjacencyMap a -> AdjacencyMap a
forall a. (a -> Bool) -> AdjacencyMap a -> AdjacencyMap a
induce (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set a
ls) AdjacencyMap a
g)
  where ls :: Set a
ls = AdjacencyMap a -> Set a
forall a. Ord a => AdjacencyMap a -> Set a
leaves AdjacencyMap a
g

-- | Questions to be answered in conflict checks:
-- 1. Is the package ignored in `pacman.conf`?
-- 2. Is the version requested different from the one provided by
--    the most recent version?
realPkgConflicts :: Settings -> PkgName -> Package -> Dep -> Maybe DepError
realPkgConflicts :: Settings -> PkgName -> Package -> Dep -> Maybe DepError
realPkgConflicts Settings
ss PkgName
parent Package
pkg Dep
dep
    | PkgName
pn PkgName -> Set PkgName -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set PkgName
toIgnore              = DepError -> Maybe DepError
forall a. a -> Maybe a
Just (DepError -> Maybe DepError) -> DepError -> Maybe DepError
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> DepError
Ignored Doc AnsiStyle
failMsg1
    | VersionDemand -> Versioning -> Bool
isVersionConflict VersionDemand
reqVer Versioning
curVer = DepError -> Maybe DepError
forall a. a -> Maybe a
Just (DepError -> Maybe DepError) -> DepError -> Maybe DepError
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> DepError
VerConflict Doc AnsiStyle
failMsg2
    | Bool
otherwise                       = Maybe DepError
forall a. Maybe a
Nothing
    where pn :: PkgName
pn       = Package -> PkgName
pname Package
pkg
          curVer :: Versioning
curVer   = Package -> Versioning
pver Package
pkg Versioning -> (Versioning -> Versioning) -> Versioning
forall a b. a -> (a -> b) -> b
& ([VChunk] -> Identity [VChunk])
-> Versioning -> Identity Versioning
forall v. Semantic v => Traversal' v [VChunk]
release (([VChunk] -> Identity [VChunk])
 -> Versioning -> Identity Versioning)
-> [VChunk] -> Versioning -> Versioning
forall s t a b. ASetter s t a b -> b -> s -> t
.~ []
          reqVer :: VersionDemand
reqVer   = Dep -> VersionDemand
dDemand Dep
dep VersionDemand -> (VersionDemand -> VersionDemand) -> VersionDemand
forall a b. a -> (a -> b) -> b
& (Versioning -> Identity Versioning)
-> VersionDemand -> Identity VersionDemand
Traversal' VersionDemand Versioning
_VersionDemand ((Versioning -> Identity Versioning)
 -> VersionDemand -> Identity VersionDemand)
-> (([VChunk] -> Identity [VChunk])
    -> Versioning -> Identity Versioning)
-> ([VChunk] -> Identity [VChunk])
-> VersionDemand
-> Identity VersionDemand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([VChunk] -> Identity [VChunk])
-> Versioning -> Identity Versioning
forall v. Semantic v => Traversal' v [VChunk]
release (([VChunk] -> Identity [VChunk])
 -> VersionDemand -> Identity VersionDemand)
-> [VChunk] -> VersionDemand -> VersionDemand
forall s t a b. ASetter s t a b -> b -> s -> t
.~ []
          lang :: Language
lang     = Settings -> Language
langOf Settings
ss
          toIgnore :: Set PkgName
toIgnore = Settings -> Set PkgName
ignoresOf Settings
ss
          failMsg1 :: Doc AnsiStyle
failMsg1 = PkgName -> Language -> Doc AnsiStyle
getRealPkgConflicts_2 PkgName
pn Language
lang
          failMsg2 :: Doc AnsiStyle
failMsg2 = PkgName -> PkgName -> Text -> Text -> Language -> Doc AnsiStyle
getRealPkgConflicts_1 PkgName
parent PkgName
pn (Versioning -> Text
prettyV Versioning
curVer) (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ VersionDemand -> String
forall a. Show a => a -> String
show VersionDemand
reqVer) Language
lang

-- | Compares a (r)equested version number with a (c)urrent up-to-date one.
-- The `MustBe` case uses regexes. A dependency demanding version 7.4
-- SHOULD match as `okay` against version 7.4, 7.4.0.1, or even 7.4.0.1-2.
isVersionConflict :: VersionDemand -> Versioning -> Bool
isVersionConflict :: VersionDemand -> Versioning -> Bool
isVersionConflict VersionDemand
Anything Versioning
_     = Bool
False
isVersionConflict (LessThan Versioning
r) Versioning
c = Versioning
c Versioning -> Versioning -> Bool
forall a. Ord a => a -> a -> Bool
>= Versioning
r
isVersionConflict (MoreThan Versioning
r) Versioning
c = Versioning
c Versioning -> Versioning -> Bool
forall a. Ord a => a -> a -> Bool
<= Versioning
r
isVersionConflict (MustBe   Versioning
r) Versioning
c = Versioning
c Versioning -> Versioning -> Bool
forall a. Eq a => a -> a -> Bool
/= Versioning
r
isVersionConflict (AtLeast  Versioning
r) Versioning
c = Versioning
c Versioning -> Versioning -> Bool
forall a. Ord a => a -> a -> Bool
< Versioning
r