{-# LANGUAGE FlexibleContexts, MonoLocalBinds, TupleSections, MultiWayIf #-}
{-# LANGUAGE TypeApplications, DataKinds #-}
module Aura.Dependencies ( resolveDeps ) where
import Algebra.Graph.AdjacencyMap
import Aura.Core
import Aura.Languages
import Aura.Settings
import Aura.Types
import BasePrelude
import Control.Concurrent.STM.TQueue
import Control.Concurrent.STM.TVar
import Control.Concurrent.Throttled (throttleMaybe_)
import Control.Error.Util (note, hush)
import Control.Monad.Freer
import Control.Monad.Freer.Error
import Control.Monad.Freer.Reader
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe
import Data.Generics.Product (field)
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import Data.Set.NonEmpty (NonEmptySet)
import qualified Data.Set.NonEmpty as NES
import qualified Data.Text as T
import Data.Versions
import Data.Witherable (wither)
import Lens.Micro
import System.IO (stdout, hFlush)
data Wrote = WroteNothing | WroteNew
resolveDeps :: (Member (Reader Settings) r, Member (Error Failure) r, Member IO r) =>
Repository -> NonEmptySet Package -> Eff r (NonEmpty (NonEmptySet Package))
resolveDeps repo ps = do
ss <- ask
tv <- send $ newTVarIO M.empty
ts <- send $ newTVarIO S.empty
liftMaybeM (Failure connectionFailure_1) $ resolveDeps' ss repo tv ts ps
m <- send $ readTVarIO tv
s <- send $ readTVarIO ts
unless (length ps == length m) $ send (putStr "\n")
let de = conflicts ss m s
unless (null de) . throwError . Failure $ missingPkg_2 de
either throwError pure $ sortInstall m
resolveDeps' :: Settings -> Repository -> TVar (M.Map PkgName Package) -> TVar (S.Set PkgName) -> NonEmptySet Package -> IO (Maybe ())
resolveDeps' ss repo tv ts ps = hush <$> throttleMaybe_ h ps
where
h :: TQueue Package -> Package -> IO (Maybe ())
h tq p = do
w <- atomically $ do
let pn = pname p
m <- readTVar tv
case M.lookup pn m of
Just _ -> pure WroteNothing
Nothing -> modifyTVar' tv (M.insert pn p) $> WroteNew
case w of
WroteNothing -> pure $ Just ()
WroteNew -> case p of
FromRepo _ -> pure $ Just ()
FromAUR b -> readTVarIO tv >>= j tq b
j :: TQueue Package -> Buildable -> M.Map PkgName Package -> IO (Maybe ())
j tq b m = do
s <- readTVarIO ts
(ds, sd) <- fmap partitionEithers . wither (satisfied m s) $ b ^. field @"deps"
atomically $ modifyTVar' ts (<> S.fromList sd)
case NEL.nonEmpty $ ds ^.. each . field @"name" of
Nothing -> pure $ Just ()
Just deps' -> do
putStr "." *> hFlush stdout
runMaybeT $ MaybeT (repoLookup repo ss $ NES.fromNonEmpty deps') >>= \(_, goods) ->
unless (null goods) (lift . atomically $ traverse_ (writeTQueue tq) goods)
satisfied :: M.Map PkgName Package -> S.Set PkgName -> Dep -> IO (Maybe (Either Dep PkgName))
satisfied m s d | M.member dn m || S.member dn s = pure Nothing
| otherwise = Just . bool (Left d) (Right dn) <$> isSatisfied d
where dn = d ^. field @"name"
conflicts :: Settings -> M.Map PkgName Package -> S.Set PkgName -> [DepError]
conflicts ss m s = foldMap f m
where pm = M.fromList $ foldr (\p acc -> (pprov p ^. field @"provides" . to PkgName, p) : acc) [] m
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 :: M.Map PkgName Package -> Either Failure (NonEmpty (NonEmptySet Package))
sortInstall m = case cycles depGraph of
[] -> note (Failure missingPkg_3) . NEL.nonEmpty . mapMaybe NES.fromSet $ batch depGraph
cs -> Left . Failure . missingPkg_4 $ map (map pname . vertexList) 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 -> [AdjacencyMap a]
cycles x = [ induce (`S.member` c) x | c <- cs ]
where cs = filter (\c -> S.size c > 1) $ vertexList (scc x)
leaves :: Ord a => AdjacencyMap a -> S.Set a
leaves x = S.filter (null . flip postSet x) $ vertexSet x
batch :: Ord a => AdjacencyMap a -> [S.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