module Debian.Repo.Dependencies
( simplifyRelations
, solutions
, testArch
) where
import Debian.Control()
import qualified Debian.Control.String as S()
import Debian.Repo.Types
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import Debian.Relation
import Extra.List (cartesianProduct)
type Excuse = String
type ProvidesMap = Map.Map String [BinaryPackage]
type SimpleRelation = Maybe PkgVersion
type SimpleRelations = [[SimpleRelation]]
instance PackageVersion BinaryPackage where
pkgName = packageName . packageID
pkgVersion = packageVersion . packageID
testArch :: Arch -> Relation -> Bool
testArch _ (Rel _ _ Nothing) = True
testArch architecture (Rel _ _ (Just (ArchOnly archList))) = elem architecture (map Binary archList)
testArch architecture (Rel _ _ (Just (ArchExcept archList))) = not (elem architecture (map Binary archList))
simplifyRelations :: [BinaryPackage]
-> Relations
-> [String]
-> Arch
-> SimpleRelations
simplifyRelations available relations preferred arch =
map (sortBy prefOrder . reverse . sort) relationsSimplified
where
relationsSimplified = expandVirtual nameMap providesMap relationsOfArch
where
nameMap = listMap (map (\ package -> (packageName (packageID package), package)) available)
providesMap =
listMap (concat (map (\ package ->
let names = packageName (packageID package) : map provides (pProvides package) in
map (\ name -> (name, package)) names) available))
provides [Rel name Nothing Nothing] = name
provides bzzt = error ("Invalid relation in Provides: " ++ show bzzt)
relationsOfArch = filter (/= []) (map (nub . filter (testArch arch)) relations)
prefOrder a b = compare (isPreferred a) (isPreferred b)
where isPreferred = maybe False (flip elem preferred . getName)
expandVirtual :: ProvidesMap -> ProvidesMap -> Relations -> SimpleRelations
expandVirtual nameMap providesMap relations =
map (nub . concat . map expand) relations
where
expand (Rel name Nothing Nothing) = map eqRel (Map.findWithDefault [] name providesMap)
expand rel@(Rel name _ _) = map eqRel (filter (satisfies rel) (Map.findWithDefault [] name nameMap))
eqRel :: BinaryPackage -> SimpleRelation
eqRel package =
Just (PkgVersion {getName = packageName p, getVersion = packageVersion p})
where p = packageID package
satisfies :: PackageVersion a => Relation -> a -> Bool
satisfies rel pkg = testRel (pkgVersion pkg) rel
testRel _ (Rel _ Nothing _) = True
testRel ver1 (Rel _ (Just (LTE ver2)) _) = not (compare ver1 ver2 == GT)
testRel ver1 (Rel _ (Just (GRE ver2)) _) = not (compare ver1 ver2 == LT)
testRel ver1 (Rel _ (Just (SLT ver2)) _) = compare ver1 ver2 == LT
testRel ver1 (Rel _ (Just (EEQ ver2)) _) = compare ver1 ver2 == EQ
testRel ver1 (Rel _ (Just (SGR ver2)) _) = compare ver1 ver2 == GT
solutions :: [BinaryPackage]
-> SimpleRelations
-> Int
-> (Either String [(Int, [BinaryPackage])])
solutions available relations limit =
case any (== []) relations of
True -> Left "Unsatisfiable dependencies"
False ->
let alternatives = map (map nub . groupByName) (cartesianProduct relations) in
case solutions' 1 alternatives available of
Left message ->
let results = map (testAlternative available) (take 20 alternatives) in
let (errors :: [String]) = catMaybes (map (either Just (const Nothing)) results) in
Left (message ++ "\n" ++ intercalate "\n" errors)
Right x -> Right x
where
solutions' :: PackageVersion a => Int -> [[[SimpleRelation]]] -> [a] -> Either String [(Int, [a])]
solutions' _ [] _ = Left "All candidate solutions failed"
solutions' count (alternative : alternatives) available =
if count > limit then
Left ("No solutions found in first " ++ show limit ++ " candidates") else
case testAlternative available alternative of
Left _ ->
solutions' (count + 1) alternatives available
Right solution ->
Right ((count, solution)
: either (const []) id (solutions' (count + 1) alternatives available))
testAlternative :: PackageVersion a => [a] -> [[SimpleRelation]] -> Either Excuse [a]
testAlternative available alternative =
if all (/= []) solution then
Right (map head solution) else
Left ("Couldn't satisfy these conditions:\n " ++
intercalate "\n " (map show (mask (map (== []) solution) alternative)))
where
solution = map (testPackage available) alternative
mask bits elems = map fst (filter snd (zip elems bits))
testPackage :: PackageVersion a => [a] -> [SimpleRelation] -> [a]
testPackage available rels = foldl satisfies available rels
where
satisfies :: PackageVersion a => [a] -> SimpleRelation -> [a]
satisfies available Nothing = available
satisfies available (Just pkg) = filter same available
where same x = pkgName x == pkgName pkg && pkgVersion x == pkgVersion pkg
groupByName :: [SimpleRelation] -> [[SimpleRelation]]
groupByName relations =
groupBy (\ a b -> compareNames a b == EQ) (sortBy compareNames relations)
where compareNames a b = compare (maybe Nothing (Just . getName) a) (maybe Nothing (Just . getName) b)
listMap :: (Ord k) => [(k, a)] -> Map.Map k [a]
listMap pairs =
foldl insertPair Map.empty pairs
where insertPair m (k,a) = Map.insert k (a : (Map.findWithDefault [] k m)) m