{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
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.Languages
import Aura.Settings
import Aura.Types
import Aura.Utils (maybe')
import BasePrelude
import Control.Effect (Carrier, Member)
import Control.Effect.Error (Error, throwError)
import Control.Effect.Lift (Lift, sendM)
import Control.Effect.Reader (Reader, asks)
import Control.Error.Util (note)
import Data.Generics.Product (field)
import qualified Data.List.NonEmpty as NEL
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Semigroup.Foldable (foldMap1)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Set.NonEmpty (pattern IsEmpty, pattern IsNonEmpty, NESet)
import qualified Data.Set.NonEmpty as NES
import qualified Data.Text as T
import Data.These (these)
import Data.Versions
import Lens.Micro
import UnliftIO.Exception (catchAny, throwString)
data Resolution = Resolution
{ toInstall :: Map PkgName Package
, satisfied :: Set PkgName }
deriving (Generic)
resolveDeps :: (Carrier sig m, Member (Reader Env) sig, Member (Error Failure) sig, Member (Lift IO) sig) =>
Repository -> NESet Package -> m (NonEmpty (NESet Package))
resolveDeps repo ps = do
ss <- asks settings
Resolution m s <- liftMaybeM (Failure connectionFailure_1) . sendM $
(Just <$> resolveDeps' ss repo ps) `catchAny` (const $ pure Nothing)
unless (length ps == length m) $ sendM (putStr "\n")
let de = conflicts ss m s
unless (null de) . throwError . Failure $ missingPkg_2 de
either throwError pure $ sortInstall m
resolveDeps' :: Settings -> Repository -> NESet Package -> IO Resolution
resolveDeps' ss repo ps = resolve (Resolution mempty mempty) ps
where
resolve :: Resolution -> NESet Package -> IO Resolution
resolve r@(Resolution m _) xs = maybe' (pure r) (NES.nonEmptySet goods) $ \goods' -> do
let m' = M.fromList (map (pname &&& id) $ toList goods')
r' = r & field @"toInstall" %~ (<> m')
these (const $ pure r') (satisfy r') (const $ satisfy r') $ dividePkgs goods'
where
goods :: Set Package
goods = NES.filter (\p -> not $ pname p `M.member` m) xs
allDeps :: NESet Buildable -> Set Dep
allDeps = foldMap1 (S.fromList . (^.. field @"deps" . each))
freshDeps :: Resolution -> Set Dep -> Set Dep
freshDeps (Resolution m s) = S.filter f
where
f :: Dep -> Bool
f d = let n = d ^. field @"name" in not $ M.member n m || S.member n s
satisfy :: Resolution -> NESet Buildable -> IO Resolution
satisfy r bs = maybe' (pure r) (NES.nonEmptySet . freshDeps r $ allDeps bs) $
areSatisfied >=> these (lookups r) (pure . r') (\uns sat -> lookups (r' sat) uns)
where
r' :: Satisfied -> Resolution
r' (Satisfied sat) = r & field @"satisfied" %~ (<> f sat)
f :: NESet Dep -> Set PkgName
f = S.map (^. field @"name") . NES.toSet
lookups :: Resolution -> Unsatisfied -> IO Resolution
lookups r (Unsatisfied ds) = do
let names = NES.map (^. field @"name") ds
repoLookup repo ss names >>= \case
Nothing -> throwString "AUR Connection Error"
Just (_, IsEmpty) -> throwString "Non-existant deps"
Just (_, IsNonEmpty goods) -> resolve r goods
conflicts :: Settings -> Map PkgName Package -> Set PkgName -> [DepError]
conflicts ss m s = foldMap f m
where
pm :: Map PkgName Package
pm = M.fromList $ foldr (\p acc -> (pprov p ^. field @"provides", p) : acc) [] m
f :: Package -> [DepError]
f (FromRepo _) = []
f (FromAUR b) = flip mapMaybe (b ^. field @"deps") $ \d ->
let dn = d ^. field @"name"
in if | S.member dn s -> Nothing
| otherwise -> case M.lookup dn m <|> M.lookup dn pm of
Nothing -> Just $ NonExistant dn
Just p -> realPkgConflicts ss (b ^. field @"name") p d
sortInstall :: Map PkgName Package -> Either Failure (NonEmpty (NESet Package))
sortInstall m = case cycles depGraph of
[] -> note (Failure missingPkg_3) . NEL.nonEmpty . mapMaybe NES.nonEmptySet $ batch depGraph
cs -> Left . Failure . missingPkg_4 $ map (NEL.map pname . NAM.vertexList1) cs
where f (FromRepo _) = []
f p@(FromAUR b) = mapMaybe (\d -> fmap (p,) $ (d ^. field @"name") `M.lookup` m) $ b ^. field @"deps"
depGraph = overlay connected singles
elems = M.elems m
connected = edges $ foldMap f elems
singles = overlays $ map vertex elems
cycles :: Ord a => AdjacencyMap a -> [NAM.AdjacencyMap a]
cycles = filter (not . isAcyclic) . vertexList . scc
leaves :: Ord a => AdjacencyMap a -> Set a
leaves x = S.filter (null . flip postSet x) $ vertexSet x
batch :: Ord a => AdjacencyMap a -> [Set a]
batch g | isEmpty g = []
| otherwise = ls : batch (induce (`S.notMember` ls) g)
where ls = leaves g
realPkgConflicts :: Settings -> PkgName -> Package -> Dep -> Maybe DepError
realPkgConflicts ss parent pkg dep
| pn `elem` toIgnore = Just $ Ignored failMsg1
| isVersionConflict reqVer curVer = Just $ VerConflict failMsg2
| otherwise = Nothing
where pn = pname pkg
curVer = pver pkg & release .~ []
reqVer = (dep ^. field @"demand") & _VersionDemand . release .~ []
lang = langOf ss
toIgnore = ignoresOf ss
failMsg1 = getRealPkgConflicts_2 pn lang
failMsg2 = getRealPkgConflicts_1 parent pn (prettyV curVer) (T.pack $ show reqVer) lang
isVersionConflict :: VersionDemand -> Versioning -> Bool
isVersionConflict Anything _ = False
isVersionConflict (LessThan r) c = c >= r
isVersionConflict (MoreThan r) c = c <= r
isVersionConflict (MustBe r) c = c /= r
isVersionConflict (AtLeast r) c = c < r