{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-}
{-# LANGUAGE NoDisambiguateRecordFields, NoRecordWildCards #-}
module Debian.GenBuildDeps
( DepInfo(..)
, sourceName'
, relations'
, binaryNames'
, buildDependencies
, RelaxInfo
, relaxDeps
, BuildableInfo(..)
, ReadyTarget(..)
, buildable
, compareSource
, orderSource
, genDeps
, failPackage
, getSourceOrder
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Exception (throw)
import Control.Monad (filterM, foldM)
import Control.Monad.State (evalState, get, modify, State)
import Data.Graph (Graph, Edge, Vertex, buildG, topSort, reachable, transposeG, edges, scc)
import Data.List as List (elemIndex, find, map, nub, partition, tails)
import Data.Map as Map (empty, findWithDefault, fromList, insert, Map, lookup)
import Data.Maybe
import Data.Set as Set (fromList, intersection, null, Set)
import Data.Tree as Tree (Tree(Node, rootLabel, subForest))
import Debian.Control (parseControlFromFile)
import Debian.Control.Policy (HasDebianControl, DebianControl, ControlFileError(..), validateDebianControl, debianSourcePackageName, debianBinaryPackageNames, debianBuildDeps, debianBuildDepsIndep)
import Debian.Loc (__LOC__)
import Debian.Relation
import Debian.Relation.Text ()
import System.Directory (getDirectoryContents, doesFileExist)
data DepInfo = DepInfo {
DepInfo -> SrcPkgName
sourceName :: SrcPkgName
, DepInfo -> Relations
relations :: Relations
, DepInfo -> [BinPkgName]
binaryNames :: [BinPkgName]
, DepInfo -> Set BinPkgName
depSet :: Set.Set BinPkgName
, DepInfo -> Set BinPkgName
binSet :: Set.Set BinPkgName
} deriving Vertex -> DepInfo -> ShowS
[DepInfo] -> ShowS
DepInfo -> [Char]
(Vertex -> DepInfo -> ShowS)
-> (DepInfo -> [Char]) -> ([DepInfo] -> ShowS) -> Show DepInfo
forall a.
(Vertex -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Vertex -> DepInfo -> ShowS
showsPrec :: Vertex -> DepInfo -> ShowS
$cshow :: DepInfo -> [Char]
show :: DepInfo -> [Char]
$cshowList :: [DepInfo] -> ShowS
showList :: [DepInfo] -> ShowS
Show
instance Eq DepInfo where
DepInfo
a == :: DepInfo -> DepInfo -> Bool
== DepInfo
b = (DepInfo -> SrcPkgName
sourceName DepInfo
a SrcPkgName -> SrcPkgName -> Bool
forall a. Eq a => a -> a -> Bool
== DepInfo -> SrcPkgName
sourceName DepInfo
b) Bool -> Bool -> Bool
&&
[Set Relation] -> Set (Set Relation)
forall a. Ord a => [a] -> Set a
Set.fromList ((OrRelation -> Set Relation) -> Relations -> [Set Relation]
forall a b. (a -> b) -> [a] -> [b]
map OrRelation -> Set Relation
forall a. Ord a => [a] -> Set a
Set.fromList (DepInfo -> Relations
relations DepInfo
a)) Set (Set Relation) -> Set (Set Relation) -> Bool
forall a. Eq a => a -> a -> Bool
== [Set Relation] -> Set (Set Relation)
forall a. Ord a => [a] -> Set a
Set.fromList ((OrRelation -> Set Relation) -> Relations -> [Set Relation]
forall a b. (a -> b) -> [a] -> [b]
map OrRelation -> Set Relation
forall a. Ord a => [a] -> Set a
Set.fromList (DepInfo -> Relations
relations DepInfo
b)) Bool -> Bool -> Bool
&&
[BinPkgName] -> Set BinPkgName
forall a. Ord a => [a] -> Set a
Set.fromList (DepInfo -> [BinPkgName]
binaryNames DepInfo
a) Set BinPkgName -> Set BinPkgName -> Bool
forall a. Eq a => a -> a -> Bool
== [BinPkgName] -> Set BinPkgName
forall a. Ord a => [a] -> Set a
Set.fromList (DepInfo -> [BinPkgName]
binaryNames DepInfo
b)
buildDependencies :: HasDebianControl control => control -> DepInfo
buildDependencies :: forall control. HasDebianControl control => control -> DepInfo
buildDependencies control
control = do
let rels :: Relations
rels = [Relations] -> Relations
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Relations -> Maybe Relations -> Relations
forall a. a -> Maybe a -> a
fromMaybe [] (control -> Maybe Relations
forall a. HasDebianControl a => a -> Maybe Relations
debianBuildDeps control
control),
Relations -> Maybe Relations -> Relations
forall a. a -> Maybe a -> a
fromMaybe [] (control -> Maybe Relations
forall a. HasDebianControl a => a -> Maybe Relations
debianBuildDepsIndep control
control)]
bins :: [BinPkgName]
bins = control -> [BinPkgName]
forall a. HasDebianControl a => a -> [BinPkgName]
debianBinaryPackageNames control
control
DepInfo { sourceName :: SrcPkgName
sourceName = control -> SrcPkgName
forall a. HasDebianControl a => a -> SrcPkgName
debianSourcePackageName control
control
, relations :: Relations
relations = Relations
rels
, binaryNames :: [BinPkgName]
binaryNames = [BinPkgName]
bins
, depSet :: Set BinPkgName
depSet = [BinPkgName] -> Set BinPkgName
forall a. Ord a => [a] -> Set a
Set.fromList ((Relation -> BinPkgName) -> OrRelation -> [BinPkgName]
forall a b. (a -> b) -> [a] -> [b]
List.map (\(Rel BinPkgName
x Maybe VersionReq
_ Maybe ArchitectureReq
_) -> BinPkgName
x) (Relations -> OrRelation
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Relations
rels))
, binSet :: Set BinPkgName
binSet = [BinPkgName] -> Set BinPkgName
forall a. Ord a => [a] -> Set a
Set.fromList [BinPkgName]
bins }
sourceName' :: HasDebianControl control => control -> SrcPkgName
sourceName' :: forall a. HasDebianControl a => a -> SrcPkgName
sourceName' control
control = control -> SrcPkgName
forall a. HasDebianControl a => a -> SrcPkgName
debianSourcePackageName control
control
relations' :: HasDebianControl control => control -> Relations
relations' :: forall control. HasDebianControl control => control -> Relations
relations' control
control = [Relations] -> Relations
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Relations -> Maybe Relations -> Relations
forall a. a -> Maybe a -> a
fromMaybe [] (control -> Maybe Relations
forall a. HasDebianControl a => a -> Maybe Relations
debianBuildDeps control
control),
Relations -> Maybe Relations -> Relations
forall a. a -> Maybe a -> a
fromMaybe [] (control -> Maybe Relations
forall a. HasDebianControl a => a -> Maybe Relations
debianBuildDepsIndep control
control)]
binaryNames' :: HasDebianControl control => control -> [BinPkgName]
binaryNames' :: forall a. HasDebianControl a => a -> [BinPkgName]
binaryNames' control
control = control -> [BinPkgName]
forall a. HasDebianControl a => a -> [BinPkgName]
debianBinaryPackageNames control
control
newtype OldRelaxInfo = RelaxInfo [(BinPkgName, Maybe SrcPkgName)] deriving Vertex -> OldRelaxInfo -> ShowS
[OldRelaxInfo] -> ShowS
OldRelaxInfo -> [Char]
(Vertex -> OldRelaxInfo -> ShowS)
-> (OldRelaxInfo -> [Char])
-> ([OldRelaxInfo] -> ShowS)
-> Show OldRelaxInfo
forall a.
(Vertex -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Vertex -> OldRelaxInfo -> ShowS
showsPrec :: Vertex -> OldRelaxInfo -> ShowS
$cshow :: OldRelaxInfo -> [Char]
show :: OldRelaxInfo -> [Char]
$cshowList :: [OldRelaxInfo] -> ShowS
showList :: [OldRelaxInfo] -> ShowS
Show
type RelaxInfo = SrcPkgName -> BinPkgName -> Bool
relaxDeps :: RelaxInfo -> [DepInfo] -> [DepInfo]
relaxDeps :: RelaxInfo -> [DepInfo] -> [DepInfo]
relaxDeps RelaxInfo
relaxInfo [DepInfo]
deps =
(DepInfo -> DepInfo) -> [DepInfo] -> [DepInfo]
forall a b. (a -> b) -> [a] -> [b]
List.map DepInfo -> DepInfo
relaxDep [DepInfo]
deps
where
relaxDep :: DepInfo -> DepInfo
relaxDep :: DepInfo -> DepInfo
relaxDep DepInfo
info = DepInfo
info {relations :: Relations
relations = Relations
filteredDependencies}
where
filteredDependencies :: Relations
filteredDependencies :: Relations
filteredDependencies = (OrRelation -> Bool) -> Relations -> Relations
forall a. (a -> Bool) -> [a] -> [a]
filter (OrRelation -> OrRelation -> Bool
forall a. Eq a => a -> a -> Bool
/= []) ((OrRelation -> OrRelation) -> Relations -> Relations
forall a b. (a -> b) -> [a] -> [b]
List.map ((Relation -> Bool) -> OrRelation -> OrRelation
forall a. (a -> Bool) -> [a] -> [a]
filter Relation -> Bool
keepDep) (DepInfo -> Relations
relations DepInfo
info))
keepDep :: Relation -> Bool
keepDep :: Relation -> Bool
keepDep (Rel BinPkgName
name Maybe VersionReq
_ Maybe ArchitectureReq
_) = Bool -> Bool
not (RelaxInfo
relaxInfo (DepInfo -> SrcPkgName
sourceName DepInfo
info) BinPkgName
name)
data ReadyTarget a
= ReadyTarget { forall a. ReadyTarget a -> a
ready :: a
, forall a. ReadyTarget a -> [a]
waiting :: [a]
, forall a. ReadyTarget a -> [a]
other :: [a]
}
data BuildableInfo a
= BuildableInfo
{ forall a. BuildableInfo a -> [ReadyTarget a]
readyTargets :: [ReadyTarget a]
, forall a. BuildableInfo a -> [a]
allBlocked :: [a] }
| CycleInfo
{ forall a. BuildableInfo a -> [(a, a)]
depPairs :: [(a, a)] }
buildable :: forall a. (a -> DepInfo) -> [a] -> BuildableInfo a
buildable :: forall a. (a -> DepInfo) -> [a] -> BuildableInfo a
buildable a -> DepInfo
relax [a]
packages =
case (Vertex -> Bool) -> [Vertex] -> ([Vertex], [Vertex])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\ Vertex
x -> Graph -> Vertex -> [Vertex]
reachable Graph
hasDep Vertex
x [Vertex] -> [Vertex] -> Bool
forall a. Eq a => a -> a -> Bool
== [Vertex
x]) [Vertex]
verts of
([], [Vertex]
_) -> CycleInfo {depPairs :: [(a, a)]
depPairs = ((Vertex, Vertex) -> (a, a)) -> [(Vertex, Vertex)] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
List.map (Vertex, Vertex) -> (a, a)
ofEdge ([(Vertex, Vertex)] -> [(a, a)]) -> [(Vertex, Vertex)] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ [[(Vertex, Vertex)]] -> [(Vertex, Vertex)]
forall a. HasCallStack => [a] -> a
head ([[(Vertex, Vertex)]] -> [(Vertex, Vertex)])
-> [[(Vertex, Vertex)]] -> [(Vertex, Vertex)]
forall a b. (a -> b) -> a -> b
$ (Graph -> [[(Vertex, Vertex)]]
allCycles Graph
hasDep)}
([Vertex]
allReady, [Vertex]
blocked) ->
BuildableInfo { readyTargets :: [ReadyTarget a]
readyTargets = (Vertex -> ReadyTarget a) -> [Vertex] -> [ReadyTarget a]
forall a b. (a -> b) -> [a] -> [b]
List.map ([Vertex] -> [Vertex] -> Vertex -> ReadyTarget a
makeReady [Vertex]
blocked [Vertex]
allReady) [Vertex]
allReady
, allBlocked :: [a]
allBlocked = (Vertex -> a) -> [Vertex] -> [a]
forall a b. (a -> b) -> [a] -> [b]
List.map Vertex -> a
ofVertex [Vertex]
blocked }
where
makeReady :: [Vertex] -> [Vertex] -> Vertex -> ReadyTarget a
makeReady :: [Vertex] -> [Vertex] -> Vertex -> ReadyTarget a
makeReady [Vertex]
blocked [Vertex]
ready Vertex
thisReady =
let otherReady :: [Vertex]
otherReady = (Vertex -> Bool) -> [Vertex] -> [Vertex]
forall a. (a -> Bool) -> [a] -> [a]
filter (Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
/= Vertex
thisReady) [Vertex]
ready
([Vertex]
directlyBlocked, [Vertex]
otherBlocked) = (Vertex -> Bool) -> [Vertex] -> ([Vertex], [Vertex])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\ Vertex
x -> Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Vertex
x (Graph -> Vertex -> [Vertex]
reachable Graph
isDep Vertex
thisReady)) [Vertex]
blocked in
ReadyTarget { ready :: a
ready = Vertex -> a
ofVertex Vertex
thisReady
, waiting :: [a]
waiting = (Vertex -> a) -> [Vertex] -> [a]
forall a b. (a -> b) -> [a] -> [b]
List.map Vertex -> a
ofVertex [Vertex]
directlyBlocked
, other :: [a]
other = (Vertex -> a) -> [Vertex] -> [a]
forall a b. (a -> b) -> [a] -> [b]
List.map Vertex -> a
ofVertex ([Vertex]
otherReady [Vertex] -> [Vertex] -> [Vertex]
forall a. [a] -> [a] -> [a]
++ [Vertex]
otherBlocked) }
isDep :: Graph
isDep :: Graph
isDep = Graph -> Graph
transposeG Graph
hasDep
hasDep :: Graph
hasDep :: Graph
hasDep = (Vertex, Vertex) -> [(Vertex, Vertex)] -> Graph
buildG (Vertex
0, [a] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [a]
packages Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
- Vertex
1) [(Vertex, Vertex)]
hasDepEdges
hasDepEdges :: [(Int, Int)]
hasDepEdges :: [(Vertex, Vertex)]
hasDepEdges =
#if 0
nub (foldr f [] (tails vertPairs))
where f :: [(Int, DepInfo)] -> [(Int, Int)] -> [(Int, Int)]
f [] es = es
f (x : xs) es = catMaybes (List.map (toEdge x) xs) ++ es
toEdge :: (Int, DepInfo) -> (Int, DepInfo) -> Maybe Edge
toEdge (xv, xa) (yv, ya) =
case compareSource xa ya of
EQ -> Nothing
LT -> Just (yv, xv)
GT -> Just (xv, yv)
#else
[(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. Eq a => [a] -> [a]
nub (State (Map (Vertex, Vertex) Ordering) [(Vertex, Vertex)]
-> Map (Vertex, Vertex) Ordering -> [(Vertex, Vertex)]
forall s a. State s a -> s -> a
evalState (([(Vertex, Vertex)]
-> [(Vertex, DepInfo)]
-> State (Map (Vertex, Vertex) Ordering) [(Vertex, Vertex)])
-> [(Vertex, Vertex)]
-> [[(Vertex, DepInfo)]]
-> State (Map (Vertex, Vertex) Ordering) [(Vertex, Vertex)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [(Vertex, Vertex)]
-> [(Vertex, DepInfo)]
-> State (Map (Vertex, Vertex) Ordering) [(Vertex, Vertex)]
f [] ([(Vertex, DepInfo)] -> [[(Vertex, DepInfo)]]
forall a. [a] -> [[a]]
tails [(Vertex, DepInfo)]
vertPairs)) Map (Vertex, Vertex) Ordering
forall k a. Map k a
Map.empty)
where f :: [(Int, Int)] -> [(Int, DepInfo)] -> State (Map.Map (Int, Int) Ordering) [(Int, Int)]
f :: [(Vertex, Vertex)]
-> [(Vertex, DepInfo)]
-> State (Map (Vertex, Vertex) Ordering) [(Vertex, Vertex)]
f [(Vertex, Vertex)]
es [] = [(Vertex, Vertex)]
-> State (Map (Vertex, Vertex) Ordering) [(Vertex, Vertex)]
forall a. a -> StateT (Map (Vertex, Vertex) Ordering) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Vertex, Vertex)]
es
f [(Vertex, Vertex)]
es ((Vertex, DepInfo)
x : [(Vertex, DepInfo)]
xs) = ((Vertex, DepInfo)
-> StateT
(Map (Vertex, Vertex) Ordering) Identity (Maybe (Vertex, Vertex)))
-> [(Vertex, DepInfo)]
-> StateT
(Map (Vertex, Vertex) Ordering) Identity [Maybe (Vertex, Vertex)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Vertex, DepInfo)
-> (Vertex, DepInfo)
-> StateT
(Map (Vertex, Vertex) Ordering) Identity (Maybe (Vertex, Vertex))
toEdge (Vertex, DepInfo)
x) [(Vertex, DepInfo)]
xs StateT
(Map (Vertex, Vertex) Ordering) Identity [Maybe (Vertex, Vertex)]
-> ([Maybe (Vertex, Vertex)]
-> State (Map (Vertex, Vertex) Ordering) [(Vertex, Vertex)])
-> State (Map (Vertex, Vertex) Ordering) [(Vertex, Vertex)]
forall a b.
StateT (Map (Vertex, Vertex) Ordering) Identity a
-> (a -> StateT (Map (Vertex, Vertex) Ordering) Identity b)
-> StateT (Map (Vertex, Vertex) Ordering) Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Maybe (Vertex, Vertex)]
es' -> [(Vertex, Vertex)]
-> State (Map (Vertex, Vertex) Ordering) [(Vertex, Vertex)]
forall a. a -> StateT (Map (Vertex, Vertex) Ordering) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe (Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Vertex, Vertex)]
es' [(Vertex, Vertex)] -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)]
es)
toEdge :: (Int, DepInfo) -> (Int, DepInfo) -> State (Map.Map (Int, Int) Ordering) (Maybe Edge)
toEdge :: (Vertex, DepInfo)
-> (Vertex, DepInfo)
-> StateT
(Map (Vertex, Vertex) Ordering) Identity (Maybe (Vertex, Vertex))
toEdge (Vertex
xv, DepInfo
xa) (Vertex
yv, DepInfo
ya) = do
Map (Vertex, Vertex) Ordering
mp <- StateT
(Map (Vertex, Vertex) Ordering)
Identity
(Map (Vertex, Vertex) Ordering)
forall s (m :: * -> *). MonadState s m => m s
get
Ordering
r <- case (Vertex, Vertex) -> Map (Vertex, Vertex) Ordering -> Maybe Ordering
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Vertex
xv, Vertex
yv) Map (Vertex, Vertex) Ordering
mp of
Just Ordering
r' -> Ordering
-> StateT (Map (Vertex, Vertex) Ordering) Identity Ordering
forall a. a -> StateT (Map (Vertex, Vertex) Ordering) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
r'
Maybe Ordering
Nothing -> do
let r' :: Ordering
r' = DepInfo -> DepInfo -> Ordering
compareSource DepInfo
xa DepInfo
ya
(Map (Vertex, Vertex) Ordering -> Map (Vertex, Vertex) Ordering)
-> StateT (Map (Vertex, Vertex) Ordering) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Vertex, Vertex)
-> Ordering
-> Map (Vertex, Vertex) Ordering
-> Map (Vertex, Vertex) Ordering
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Vertex
xv, Vertex
yv) Ordering
r')
Ordering
-> StateT (Map (Vertex, Vertex) Ordering) Identity Ordering
forall a. a -> StateT (Map (Vertex, Vertex) Ordering) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
r'
case Ordering
r of
Ordering
EQ -> Maybe (Vertex, Vertex)
-> StateT
(Map (Vertex, Vertex) Ordering) Identity (Maybe (Vertex, Vertex))
forall a. a -> StateT (Map (Vertex, Vertex) Ordering) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Vertex, Vertex)
forall a. Maybe a
Nothing
Ordering
LT -> Maybe (Vertex, Vertex)
-> StateT
(Map (Vertex, Vertex) Ordering) Identity (Maybe (Vertex, Vertex))
forall a. a -> StateT (Map (Vertex, Vertex) Ordering) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Vertex, Vertex)
-> StateT
(Map (Vertex, Vertex) Ordering) Identity (Maybe (Vertex, Vertex)))
-> Maybe (Vertex, Vertex)
-> StateT
(Map (Vertex, Vertex) Ordering) Identity (Maybe (Vertex, Vertex))
forall a b. (a -> b) -> a -> b
$ (Vertex, Vertex) -> Maybe (Vertex, Vertex)
forall a. a -> Maybe a
Just (Vertex
yv, Vertex
xv)
Ordering
GT -> Maybe (Vertex, Vertex)
-> StateT
(Map (Vertex, Vertex) Ordering) Identity (Maybe (Vertex, Vertex))
forall a. a -> StateT (Map (Vertex, Vertex) Ordering) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Vertex, Vertex)
-> StateT
(Map (Vertex, Vertex) Ordering) Identity (Maybe (Vertex, Vertex)))
-> Maybe (Vertex, Vertex)
-> StateT
(Map (Vertex, Vertex) Ordering) Identity (Maybe (Vertex, Vertex))
forall a b. (a -> b) -> a -> b
$ (Vertex, Vertex) -> Maybe (Vertex, Vertex)
forall a. a -> Maybe a
Just (Vertex
xv, Vertex
yv)
#endif
ofEdge :: Edge -> (a, a)
ofEdge :: (Vertex, Vertex) -> (a, a)
ofEdge (Vertex
a, Vertex
b) = (Vertex -> a
ofVertex Vertex
a, Vertex -> a
ofVertex Vertex
b)
ofVertex :: Int -> a
ofVertex :: Vertex -> a
ofVertex Vertex
n = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> Vertex -> Map Vertex (Maybe a) -> Maybe a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Maybe a
forall a. Maybe a
Nothing Vertex
n ([(Vertex, Maybe a)] -> Map Vertex (Maybe a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Vertex] -> [Maybe a] -> [(Vertex, Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Vertex
0..] ((a -> Maybe a) -> [a] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Maybe a
forall a. a -> Maybe a
Just [a]
packages))))
verts :: [Int]
verts :: [Vertex]
verts = ((Vertex, DepInfo) -> Vertex) -> [(Vertex, DepInfo)] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map (Vertex, DepInfo) -> Vertex
forall a b. (a, b) -> a
fst [(Vertex, DepInfo)]
vertPairs
vertPairs :: [(Int, DepInfo)]
vertPairs :: [(Vertex, DepInfo)]
vertPairs = [Vertex] -> [DepInfo] -> [(Vertex, DepInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Vertex
0..] ([DepInfo] -> [(Vertex, DepInfo)])
-> [DepInfo] -> [(Vertex, DepInfo)]
forall a b. (a -> b) -> a -> b
$ (a -> DepInfo) -> [a] -> [DepInfo]
forall a b. (a -> b) -> [a] -> [b]
map a -> DepInfo
relax [a]
packages
allCycles :: Graph -> [[Edge]]
allCycles :: Graph -> [[(Vertex, Vertex)]]
allCycles Graph
g =
(Tree Vertex -> [[(Vertex, Vertex)]])
-> [Tree Vertex] -> [[(Vertex, Vertex)]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree Vertex -> [[(Vertex, Vertex)]]
sccCycles (Graph -> [Tree Vertex]
scc Graph
g)
where
sccCycles :: Tree Vertex -> [[Edge]]
sccCycles :: Tree Vertex -> [[(Vertex, Vertex)]]
sccCycles Tree Vertex
t = ([Vertex] -> Maybe [(Vertex, Vertex)])
-> [[Vertex]] -> [[(Vertex, Vertex)]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Vertex] -> Maybe [(Vertex, Vertex)]
addBackEdge (Tree Vertex -> [[Vertex]]
forall a. Tree a -> [[a]]
treePaths Tree Vertex
t)
addBackEdge :: [Vertex] -> Maybe [Edge]
addBackEdge :: [Vertex] -> Maybe [(Vertex, Vertex)]
addBackEdge path :: [Vertex]
path@(Vertex
root : [Vertex]
_) =
let back :: (Vertex, Vertex)
back = ([Vertex] -> Vertex
forall a. HasCallStack => [a] -> a
last [Vertex]
path, Vertex
root) in
if (Vertex, Vertex) -> [(Vertex, Vertex)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Vertex, Vertex)
back (Graph -> [(Vertex, Vertex)]
edges Graph
g) then [(Vertex, Vertex)] -> Maybe [(Vertex, Vertex)]
forall a. a -> Maybe a
Just ([Vertex] -> [(Vertex, Vertex)]
forall a. [a] -> [(a, a)]
pathEdges ([Vertex]
path [Vertex] -> [Vertex] -> [Vertex]
forall a. [a] -> [a] -> [a]
++ [Vertex
root])) else Maybe [(Vertex, Vertex)]
forall a. Maybe a
Nothing
treePaths :: Tree a -> [[a]]
treePaths :: forall a. Tree a -> [[a]]
treePaths (Node {rootLabel :: forall a. Tree a -> a
rootLabel = a
r, subForest :: forall a. Tree a -> [Tree a]
subForest = []}) = [[a
r]]
treePaths (Node {rootLabel :: forall a. Tree a -> a
rootLabel = a
r, subForest :: forall a. Tree a -> [Tree a]
subForest = [Tree a]
ts}) = ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
r a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ((Tree a -> [[a]]) -> [Tree a] -> [[a]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree a -> [[a]]
forall a. Tree a -> [[a]]
treePaths [Tree a]
ts)
pathEdges :: [a] -> [(a, a)]
pathEdges :: forall a. [a] -> [(a, a)]
pathEdges (a
v1 : a
v2 : [a]
vs) = (a
v1, a
v2) (a, a) -> [(a, a)] -> [(a, a)]
forall a. a -> [a] -> [a]
: [a] -> [(a, a)]
forall a. [a] -> [(a, a)]
pathEdges (a
v2 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
vs)
pathEdges [a]
_ = []
failPackage :: Eq a => (a -> a -> Ordering) -> a -> [a] -> ([a], [a])
failPackage :: forall a. Eq a => (a -> a -> Ordering) -> a -> [a] -> ([a], [a])
failPackage a -> a -> Ordering
cmp a
failed [a]
packages =
let graph :: Graph
graph = (a -> a -> Ordering) -> [a] -> Graph
forall a. (a -> a -> Ordering) -> [a] -> Graph
buildGraph a -> a -> Ordering
cmp [a]
packages in
let root :: Maybe Vertex
root = a -> [a] -> Maybe Vertex
forall a. Eq a => a -> [a] -> Maybe Vertex
elemIndex a
failed [a]
packages in
let victims :: [a]
victims = [a] -> (Vertex -> [a]) -> Maybe Vertex -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Vertex -> a) -> [Vertex] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> (Vertex -> Maybe a) -> Vertex -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vertex -> Maybe a
vertex) ([Vertex] -> [a]) -> (Vertex -> [Vertex]) -> Vertex -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> Vertex -> [Vertex]
reachable Graph
graph) Maybe Vertex
root in
(a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\ a
x -> Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
x ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ [a]
victims) [a]
packages
where
vertex :: Vertex -> Maybe a
vertex Vertex
n = Maybe a -> Vertex -> Map Vertex (Maybe a) -> Maybe a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Maybe a
forall a. Maybe a
Nothing Vertex
n Map Vertex (Maybe a)
vertexMap
vertexMap :: Map Vertex (Maybe a)
vertexMap = [(Vertex, Maybe a)] -> Map Vertex (Maybe a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Vertex] -> [Maybe a] -> [(Vertex, Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Vertex
0..] ((a -> Maybe a) -> [a] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Maybe a
forall a. a -> Maybe a
Just [a]
packages))
orderSource :: (a -> a -> Ordering) -> [a] -> [a]
orderSource :: forall a. (a -> a -> Ordering) -> [a] -> [a]
orderSource a -> a -> Ordering
cmp [a]
packages =
(Vertex -> a) -> [Vertex] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> (Vertex -> Maybe a) -> Vertex -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vertex -> Maybe a
vertex) (Graph -> [Vertex]
topSort Graph
graph)
where
graph :: Graph
graph = (a -> a -> Ordering) -> [a] -> Graph
forall a. (a -> a -> Ordering) -> [a] -> Graph
buildGraph a -> a -> Ordering
cmp [a]
packages
vertex :: Vertex -> Maybe a
vertex Vertex
n = Maybe a -> Vertex -> Map Vertex (Maybe a) -> Maybe a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Maybe a
forall a. Maybe a
Nothing Vertex
n Map Vertex (Maybe a)
vertexMap
vertexMap :: Map Vertex (Maybe a)
vertexMap = [(Vertex, Maybe a)] -> Map Vertex (Maybe a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Vertex] -> [Maybe a] -> [(Vertex, Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Vertex
0..] ((a -> Maybe a) -> [a] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Maybe a
forall a. a -> Maybe a
Just [a]
packages))
buildGraph :: (a -> a -> Ordering) -> [a] -> Graph
buildGraph :: forall a. (a -> a -> Ordering) -> [a] -> Graph
buildGraph a -> a -> Ordering
cmp [a]
packages =
let es :: [(Vertex, Vertex)]
es = [(a, Vertex)] -> [(Vertex, Vertex)]
forall {a}. [(a, a)] -> [(a, a)]
someEdges ([a] -> [Vertex] -> [(a, Vertex)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
packages [Vertex
0..]) in
(Vertex, Vertex) -> [(Vertex, Vertex)] -> Graph
buildG (Vertex
0, [a] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [a]
packages Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
- Vertex
1) [(Vertex, Vertex)]
es
where
someEdges :: [(a, a)] -> [(a, a)]
someEdges [] = []
someEdges ((a, a)
a : [(a, a)]
etc) = (a, a) -> [(a, a)] -> [(a, a)]
forall {a}. (a, a) -> [(a, a)] -> [(a, a)]
aEdges (a, a)
a [(a, a)]
etc [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [(a, a)] -> [(a, a)]
someEdges [(a, a)]
etc
aEdges :: (a, a) -> [(a, a)] -> [(a, a)]
aEdges (a
ap, a
an) [(a, a)]
etc =
[[(a, a)]] -> [(a, a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (((a, a) -> [(a, a)]) -> [(a, a)] -> [[(a, a)]]
forall a b. (a -> b) -> [a] -> [b]
map (\ (a
bp, a
bn) ->
case a -> a -> Ordering
cmp a
ap a
bp of
Ordering
LT -> [(a
an, a
bn)]
Ordering
GT -> [(a
bn, a
an)]
Ordering
EQ -> []) [(a, a)]
etc)
compareSource :: DepInfo -> DepInfo -> Ordering
compareSource :: DepInfo -> DepInfo -> Ordering
compareSource DepInfo
p1 DepInfo
p2
#if 0
| any (\rel -> isJust (find (checkPackageNameReq rel) (binaryNames p2))) (concat (relations p1)) = GT
| any (\rel -> isJust (find (checkPackageNameReq rel) (binaryNames p1))) (concat (relations p2)) = LT
| otherwise = EQ
where
checkPackageNameReq :: Relation -> BinPkgName -> Bool
checkPackageNameReq (Rel rPkgName _ _) bPkgName = rPkgName == bPkgName
#else
| Bool -> Bool
not (Set BinPkgName -> Bool
forall a. Set a -> Bool
Set.null (Set BinPkgName -> Set BinPkgName -> Set BinPkgName
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (DepInfo -> Set BinPkgName
depSet DepInfo
p1) (DepInfo -> Set BinPkgName
binSet DepInfo
p2))) = Ordering
GT
| Bool -> Bool
not (Set BinPkgName -> Bool
forall a. Set a -> Bool
Set.null (Set BinPkgName -> Set BinPkgName -> Set BinPkgName
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (DepInfo -> Set BinPkgName
depSet DepInfo
p2) (DepInfo -> Set BinPkgName
binSet DepInfo
p1))) = Ordering
LT
| Bool
otherwise = Ordering
EQ
#endif
compareSource' :: HasDebianControl control => control -> control -> Ordering
compareSource' :: forall control.
HasDebianControl control =>
control -> control -> Ordering
compareSource' control
control1 control
control2
| (Relation -> Bool) -> OrRelation -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Relation
rel -> Maybe BinPkgName -> Bool
forall a. Maybe a -> Bool
isJust ((BinPkgName -> Bool) -> [BinPkgName] -> Maybe BinPkgName
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Relation -> BinPkgName -> Bool
checkPackageNameReq Relation
rel) [BinPkgName]
bins2)) (Relations -> OrRelation
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Relations
depends1) = Ordering
GT
| (Relation -> Bool) -> OrRelation -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Relation
rel -> Maybe BinPkgName -> Bool
forall a. Maybe a -> Bool
isJust ((BinPkgName -> Bool) -> [BinPkgName] -> Maybe BinPkgName
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Relation -> BinPkgName -> Bool
checkPackageNameReq Relation
rel) [BinPkgName]
bins1)) (Relations -> OrRelation
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Relations
depends2) = Ordering
LT
| Bool
otherwise = Ordering
EQ
where
bins1 :: [BinPkgName]
bins1 = control -> [BinPkgName]
forall a. HasDebianControl a => a -> [BinPkgName]
binaryNames' control
control1
bins2 :: [BinPkgName]
bins2 = control -> [BinPkgName]
forall a. HasDebianControl a => a -> [BinPkgName]
binaryNames' control
control2
depends1 :: Relations
depends1 = control -> Relations
forall control. HasDebianControl control => control -> Relations
relations' control
control1
depends2 :: Relations
depends2 = control -> Relations
forall control. HasDebianControl control => control -> Relations
relations' control
control2
checkPackageNameReq :: Relation -> BinPkgName -> Bool
checkPackageNameReq :: Relation -> BinPkgName -> Bool
checkPackageNameReq (Rel BinPkgName
rPkgName Maybe VersionReq
_ Maybe ArchitectureReq
_) BinPkgName
bPkgName = BinPkgName
rPkgName BinPkgName -> BinPkgName -> Bool
forall a. Eq a => a -> a -> Bool
== BinPkgName
bPkgName
genDeps :: [FilePath] -> IO [DebianControl]
genDeps :: [[Char]] -> IO [DebianControl]
genDeps [[Char]]
controlFiles = do
(DebianControl -> DebianControl -> Ordering)
-> [DebianControl] -> [DebianControl]
forall a. (a -> a -> Ordering) -> [a] -> [a]
orderSource DebianControl -> DebianControl -> Ordering
forall control.
HasDebianControl control =>
control -> control -> Ordering
compareSource' ([DebianControl] -> [DebianControl])
-> IO [DebianControl] -> IO [DebianControl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> IO DebianControl) -> [[Char]] -> IO [DebianControl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Char] -> IO DebianControl
genDep' [[Char]]
controlFiles
where
genDep' :: [Char] -> IO DebianControl
genDep' [Char]
controlPath = [Char] -> IO (Either ParseError (Control' Text))
forall a.
ControlFunctions a =>
[Char] -> IO (Either ParseError (Control' a))
parseControlFromFile [Char]
controlPath IO (Either ParseError (Control' Text))
-> (Either ParseError (Control' Text) -> IO DebianControl)
-> IO DebianControl
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(ParseError -> IO DebianControl)
-> (Control' Text -> IO DebianControl)
-> Either ParseError (Control' Text)
-> IO DebianControl
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ ParseError
x -> ControlFileError -> IO DebianControl
forall a e. Exception e => e -> a
throw ([Loc] -> ParseError -> ControlFileError
ParseRelationsError [$Vertex
[Char]
[Char]
-> [Char] -> [Char] -> (Vertex, Vertex) -> (Vertex, Vertex) -> Loc
loc_filename :: [Char]
loc_package :: [Char]
loc_module :: [Char]
loc_start :: (Vertex, Vertex)
loc_end :: (Vertex, Vertex)
__LOC__] ParseError
x))
(\ Control' Text
x -> Control' Text -> IO (Either ControlFileError DebianControl)
forall (m :: * -> *).
MonadCatch m =>
Control' Text -> m (Either ControlFileError DebianControl)
validateDebianControl Control' Text
x IO (Either ControlFileError DebianControl)
-> (Either ControlFileError DebianControl -> IO DebianControl)
-> IO DebianControl
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ControlFileError -> IO DebianControl)
-> (DebianControl -> IO DebianControl)
-> Either ControlFileError DebianControl
-> IO DebianControl
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ControlFileError -> IO DebianControl
forall a e. Exception e => e -> a
throw DebianControl -> IO DebianControl
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return)
getSourceOrder :: FilePath -> IO [SrcPkgName]
getSourceOrder :: [Char] -> IO [SrcPkgName]
getSourceOrder [Char]
fp =
[Char] -> IO [[Char]]
findControlFiles [Char]
fp IO [[Char]]
-> ([[Char]] -> IO [DebianControl]) -> IO [DebianControl]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [[Char]] -> IO [DebianControl]
genDeps IO [DebianControl]
-> ([DebianControl] -> IO [SrcPkgName]) -> IO [SrcPkgName]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [SrcPkgName] -> IO [SrcPkgName]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([SrcPkgName] -> IO [SrcPkgName])
-> ([DebianControl] -> [SrcPkgName])
-> [DebianControl]
-> IO [SrcPkgName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DebianControl -> SrcPkgName) -> [DebianControl] -> [SrcPkgName]
forall a b. (a -> b) -> [a] -> [b]
map DebianControl -> SrcPkgName
forall a. HasDebianControl a => a -> SrcPkgName
sourceName'
where
findControlFiles :: FilePath -> IO [FilePath]
findControlFiles :: [Char] -> IO [[Char]]
findControlFiles [Char]
root =
[Char] -> IO [[Char]]
getDirectoryContents [Char]
root IO [[Char]] -> ([[Char]] -> IO [[Char]]) -> IO [[Char]]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
([Char] -> IO [Char]) -> [[Char]] -> IO [[Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ [Char]
x -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
root [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"/" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"/debian/control") IO [[Char]] -> ([[Char]] -> IO [[Char]]) -> IO [[Char]]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
([Char] -> IO Bool) -> [[Char]] -> IO [[Char]]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [Char] -> IO Bool
doesFileExist