{-# 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
{ toInstall :: !(Map PkgName Package)
, satisfied :: !(Set PkgName) }
deriving (Generic)
toInstallL :: Lens' Resolution (Map PkgName Package)
toInstallL f r = (\m -> r { toInstall = m }) <$> f (toInstall r)
satisfiedL :: Lens' Resolution (Set PkgName)
satisfiedL f r = (\s -> r { satisfied = s }) <$> f (satisfied r)
resolveDeps :: Repository -> NonEmpty Package -> RIO Env (NonEmpty (NonEmpty Package))
resolveDeps repo ps = do
logDebug "resolveDeps: Entered."
ss <- asks settings
res <- liftIO (Right <$> resolveDeps' ss repo ps) `catchAny` handleError
Resolution m s <- either throwM pure res
logDebug "resolveDeps: Successful recursive dep lookup."
unless (length ps == length m) $ putText "\n"
let de = conflicts ss m s
unless (null de) . throwM . Failure $ missingPkg_2 de
either throwM pure $ sortInstall m
where
handleError :: SomeException -> RIO Env (Either Failure a)
handleError e = pure . Left . Failure . dependencyLookup_1 $ tshow e
resolveDeps' :: Settings -> Repository -> NonEmpty Package -> IO Resolution
resolveDeps' ss repo ps = resolve (Resolution mempty mempty) ps
where
resolve :: Resolution -> NonEmpty Package -> IO Resolution
resolve r@(Resolution m _) xs = maybe' (pure r) (NEL.nonEmpty goods) $ \goods' -> do
let m' = M.fromList . map (pname &&& id) $ toList goods'
r' = r & toInstallL %~ (<> m')
these (const $ pure r') (satisfy r') (const $ satisfy r') $ dividePkgs goods'
where
goods :: [Package]
goods = NEL.filter (\p -> not $ pname p `M.member` m) xs
allDeps :: NonEmpty Buildable -> Set Dep
allDeps = foldMap1 (S.fromList . (^.. to bDeps . each))
freshDeps :: Resolution -> Set Dep -> Set Dep
freshDeps (Resolution m s) = S.filter f
where
f :: Dep -> Bool
f d = let n = dName d in not $ M.member n m || S.member n s
satisfy :: Resolution -> NonEmpty Buildable -> IO Resolution
satisfy r bs = maybe' (pure r) (nes . freshDeps r $ allDeps bs) $
areSatisfied (envOf ss) >=> these (lookups r) (pure . r') (\uns sat -> lookups (r' sat) uns)
where
r' :: Satisfied -> Resolution
r' (Satisfied sat) = r & satisfiedL %~ (<> f sat)
f :: NonEmpty Dep -> Set PkgName
f = S.fromList . NEL.toList . NEL.map dName
lookups :: Resolution -> Unsatisfied -> IO Resolution
lookups r (Unsatisfied ds) = do
let names = NEL.map dName ds
repoLookup repo ss names >>= \case
Nothing -> throwString "Unexpected AUR Connection Error"
Just (bads, could) -> case nes could of
Nothing -> do
let badNames = unwords . map (T.unpack . pnName) $ S.toList bads
throwString $ "Non-existant deps: " <> badNames
Just 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 $ map (\p -> (provides $ pprov p, p)) $ toList m
f :: Package -> [DepError]
f (FromRepo _) = []
f (FromAUR b) = flip mapMaybe (bDeps b) $ \d ->
let dn = dName d
in if S.member dn s then Nothing
else case M.lookup dn m <|> M.lookup dn pm of
Nothing -> Just . NonExistant dn $ bName b
Just p -> realPkgConflicts ss (bName b) p d
sortInstall :: Map PkgName Package -> Either Failure (NonEmpty (NonEmpty Package))
sortInstall m = case cycles depGraph of
[] -> note (Failure missingPkg_3) . NEL.nonEmpty . mapMaybe nes $ batch depGraph
cs -> Left . Failure . missingPkg_4 $ map (NEL.map pname . NAM.vertexList1) cs
where
f :: Package -> [(Package, Package)]
f (FromRepo _) = []
f p@(FromAUR b) = mapMaybe (\d -> fmap (p,) $ dName d `M.lookup` m)
$ bDeps b
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 = dDemand dep & _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