{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
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
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)
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
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
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
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))
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
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)
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
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
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
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
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
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
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
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