{-# 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 Int -> DepInfo -> ShowS
[DepInfo] -> ShowS
DepInfo -> String
(Int -> DepInfo -> ShowS)
-> (DepInfo -> String) -> ([DepInfo] -> ShowS) -> Show DepInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DepInfo] -> ShowS
$cshowList :: [DepInfo] -> ShowS
show :: DepInfo -> String
$cshow :: DepInfo -> String
showsPrec :: Int -> DepInfo -> ShowS
$cshowsPrec :: Int -> 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 (([Relation] -> Set Relation) -> Relations -> [Set Relation]
forall a b. (a -> b) -> [a] -> [b]
map [Relation] -> 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 (([Relation] -> Set Relation) -> Relations -> [Set Relation]
forall a b. (a -> b) -> [a] -> [b]
map [Relation] -> 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 :: 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 :: SrcPkgName
-> Relations
-> [BinPkgName]
-> Set BinPkgName
-> Set BinPkgName
-> DepInfo
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) -> [Relation] -> [BinPkgName]
forall a b. (a -> b) -> [a] -> [b]
List.map (\(Rel BinPkgName
x Maybe VersionReq
_ Maybe ArchitectureReq
_) -> BinPkgName
x) (Relations -> [Relation]
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' :: control -> SrcPkgName
sourceName' control
control = control -> SrcPkgName
forall a. HasDebianControl a => a -> SrcPkgName
debianSourcePackageName control
control
relations' :: HasDebianControl control => control -> Relations
relations' :: 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' :: control -> [BinPkgName]
binaryNames' control
control = control -> [BinPkgName]
forall a. HasDebianControl a => a -> [BinPkgName]
debianBinaryPackageNames control
control
newtype OldRelaxInfo = RelaxInfo [(BinPkgName, Maybe SrcPkgName)] deriving Int -> OldRelaxInfo -> ShowS
[OldRelaxInfo] -> ShowS
OldRelaxInfo -> String
(Int -> OldRelaxInfo -> ShowS)
-> (OldRelaxInfo -> String)
-> ([OldRelaxInfo] -> ShowS)
-> Show OldRelaxInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OldRelaxInfo] -> ShowS
$cshowList :: [OldRelaxInfo] -> ShowS
show :: OldRelaxInfo -> String
$cshow :: OldRelaxInfo -> String
showsPrec :: Int -> OldRelaxInfo -> ShowS
$cshowsPrec :: Int -> 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 = ([Relation] -> Bool) -> Relations -> Relations
forall a. (a -> Bool) -> [a] -> [a]
filter ([Relation] -> [Relation] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (([Relation] -> [Relation]) -> Relations -> Relations
forall a b. (a -> b) -> [a] -> [b]
List.map ((Relation -> Bool) -> [Relation] -> [Relation]
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 { ReadyTarget a -> a
ready :: a
, ReadyTarget a -> [a]
waiting :: [a]
, ReadyTarget a -> [a]
other :: [a]
}
data BuildableInfo a
= BuildableInfo
{ BuildableInfo a -> [ReadyTarget a]
readyTargets :: [ReadyTarget a]
, BuildableInfo a -> [a]
allBlocked :: [a] }
| CycleInfo
{ BuildableInfo a -> [(a, a)]
depPairs :: [(a, a)] }
buildable :: forall a. (a -> DepInfo) -> [a] -> BuildableInfo a
buildable :: (a -> DepInfo) -> [a] -> BuildableInfo a
buildable a -> DepInfo
relax [a]
packages =
case (Int -> Bool) -> [Int] -> ([Int], [Int])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\ Int
x -> Graph -> Int -> [Int]
reachable Graph
hasDep Int
x [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int
x]) [Int]
verts of
([], [Int]
_) -> CycleInfo :: forall a. [(a, a)] -> BuildableInfo a
CycleInfo {depPairs :: [(a, a)]
depPairs = (Edge -> (a, a)) -> [Edge] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [b]
List.map Edge -> (a, a)
ofEdge ([Edge] -> [(a, a)]) -> [Edge] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ [[Edge]] -> [Edge]
forall a. [a] -> a
head ([[Edge]] -> [Edge]) -> [[Edge]] -> [Edge]
forall a b. (a -> b) -> a -> b
$ (Graph -> [[Edge]]
allCycles Graph
hasDep)}
([Int]
allReady, [Int]
blocked) ->
BuildableInfo :: forall a. [ReadyTarget a] -> [a] -> BuildableInfo a
BuildableInfo { readyTargets :: [ReadyTarget a]
readyTargets = (Int -> ReadyTarget a) -> [Int] -> [ReadyTarget a]
forall a b. (a -> b) -> [a] -> [b]
List.map ([Int] -> [Int] -> Int -> ReadyTarget a
makeReady [Int]
blocked [Int]
allReady) [Int]
allReady
, allBlocked :: [a]
allBlocked = (Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
List.map Int -> a
ofVertex [Int]
blocked }
where
makeReady :: [Vertex] -> [Vertex] -> Vertex -> ReadyTarget a
makeReady :: [Int] -> [Int] -> Int -> ReadyTarget a
makeReady [Int]
blocked [Int]
ready Int
thisReady =
let otherReady :: [Int]
otherReady = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
thisReady) [Int]
ready
([Int]
directlyBlocked, [Int]
otherBlocked) = (Int -> Bool) -> [Int] -> ([Int], [Int])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\ Int
x -> Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Int
x (Graph -> Int -> [Int]
reachable Graph
isDep Int
thisReady)) [Int]
blocked in
ReadyTarget :: forall a. a -> [a] -> [a] -> ReadyTarget a
ReadyTarget { ready :: a
ready = Int -> a
ofVertex Int
thisReady
, waiting :: [a]
waiting = (Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
List.map Int -> a
ofVertex [Int]
directlyBlocked
, other :: [a]
other = (Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
List.map Int -> a
ofVertex ([Int]
otherReady [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
otherBlocked) }
isDep :: Graph
isDep :: Graph
isDep = Graph -> Graph
transposeG Graph
hasDep
hasDep :: Graph
hasDep :: Graph
hasDep = Edge -> [Edge] -> Graph
buildG (Int
0, [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
packages Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Edge]
hasDepEdges
hasDepEdges :: [(Int, Int)]
hasDepEdges :: [Edge]
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
[Edge] -> [Edge]
forall a. Eq a => [a] -> [a]
nub (State (Map Edge Ordering) [Edge] -> Map Edge Ordering -> [Edge]
forall s a. State s a -> s -> a
evalState (([Edge] -> [(Int, DepInfo)] -> State (Map Edge Ordering) [Edge])
-> [Edge] -> [[(Int, DepInfo)]] -> State (Map Edge Ordering) [Edge]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [Edge] -> [(Int, DepInfo)] -> State (Map Edge Ordering) [Edge]
f [] ([(Int, DepInfo)] -> [[(Int, DepInfo)]]
forall a. [a] -> [[a]]
tails [(Int, DepInfo)]
vertPairs)) Map Edge Ordering
forall k a. Map k a
Map.empty)
where f :: [(Int, Int)] -> [(Int, DepInfo)] -> State (Map.Map (Int, Int) Ordering) [(Int, Int)]
f :: [Edge] -> [(Int, DepInfo)] -> State (Map Edge Ordering) [Edge]
f [Edge]
es [] = [Edge] -> State (Map Edge Ordering) [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return [Edge]
es
f [Edge]
es ((Int, DepInfo)
x : [(Int, DepInfo)]
xs) = ((Int, DepInfo)
-> StateT (Map Edge Ordering) Identity (Maybe Edge))
-> [(Int, DepInfo)]
-> StateT (Map Edge Ordering) Identity [Maybe Edge]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Int, DepInfo)
-> (Int, DepInfo)
-> StateT (Map Edge Ordering) Identity (Maybe Edge)
toEdge (Int, DepInfo)
x) [(Int, DepInfo)]
xs StateT (Map Edge Ordering) Identity [Maybe Edge]
-> ([Maybe Edge] -> State (Map Edge Ordering) [Edge])
-> State (Map Edge Ordering) [Edge]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Maybe Edge]
es' -> [Edge] -> State (Map Edge Ordering) [Edge]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe Edge] -> [Edge]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Edge]
es' [Edge] -> [Edge] -> [Edge]
forall a. [a] -> [a] -> [a]
++ [Edge]
es)
toEdge :: (Int, DepInfo) -> (Int, DepInfo) -> State (Map.Map (Int, Int) Ordering) (Maybe Edge)
toEdge :: (Int, DepInfo)
-> (Int, DepInfo)
-> StateT (Map Edge Ordering) Identity (Maybe Edge)
toEdge (Int
xv, DepInfo
xa) (Int
yv, DepInfo
ya) = do
Map Edge Ordering
mp <- StateT (Map Edge Ordering) Identity (Map Edge Ordering)
forall s (m :: * -> *). MonadState s m => m s
get
Ordering
r <- case Edge -> Map Edge Ordering -> Maybe Ordering
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Int
xv, Int
yv) Map Edge Ordering
mp of
Just Ordering
r' -> Ordering -> StateT (Map Edge Ordering) Identity Ordering
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 Edge Ordering -> Map Edge Ordering)
-> StateT (Map Edge Ordering) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Edge -> Ordering -> Map Edge Ordering -> Map Edge Ordering
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Int
xv, Int
yv) Ordering
r')
Ordering -> StateT (Map Edge Ordering) Identity Ordering
forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
r'
case Ordering
r of
Ordering
EQ -> Maybe Edge -> StateT (Map Edge Ordering) Identity (Maybe Edge)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Edge
forall a. Maybe a
Nothing
Ordering
LT -> Maybe Edge -> StateT (Map Edge Ordering) Identity (Maybe Edge)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Edge -> StateT (Map Edge Ordering) Identity (Maybe Edge))
-> Maybe Edge -> StateT (Map Edge Ordering) Identity (Maybe Edge)
forall a b. (a -> b) -> a -> b
$ Edge -> Maybe Edge
forall a. a -> Maybe a
Just (Int
yv, Int
xv)
Ordering
GT -> Maybe Edge -> StateT (Map Edge Ordering) Identity (Maybe Edge)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Edge -> StateT (Map Edge Ordering) Identity (Maybe Edge))
-> Maybe Edge -> StateT (Map Edge Ordering) Identity (Maybe Edge)
forall a b. (a -> b) -> a -> b
$ Edge -> Maybe Edge
forall a. a -> Maybe a
Just (Int
xv, Int
yv)
#endif
ofEdge :: Edge -> (a, a)
ofEdge :: Edge -> (a, a)
ofEdge (Int
a, Int
b) = (Int -> a
ofVertex Int
a, Int -> a
ofVertex Int
b)
ofVertex :: Int -> a
ofVertex :: Int -> a
ofVertex Int
n = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> Int -> Map Int (Maybe a) -> Maybe a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Maybe a
forall a. Maybe a
Nothing Int
n ([(Int, Maybe a)] -> Map Int (Maybe a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Int] -> [Maybe a] -> [(Int, Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
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 :: [Int]
verts = ((Int, DepInfo) -> Int) -> [(Int, DepInfo)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, DepInfo) -> Int
forall a b. (a, b) -> a
fst [(Int, DepInfo)]
vertPairs
vertPairs :: [(Int, DepInfo)]
vertPairs :: [(Int, DepInfo)]
vertPairs = [Int] -> [DepInfo] -> [(Int, DepInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([DepInfo] -> [(Int, DepInfo)]) -> [DepInfo] -> [(Int, 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 -> [[Edge]]
allCycles Graph
g =
(Tree Int -> [[Edge]]) -> [Tree Int] -> [[Edge]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree Int -> [[Edge]]
sccCycles (Graph -> [Tree Int]
scc Graph
g)
where
sccCycles :: Tree Vertex -> [[Edge]]
sccCycles :: Tree Int -> [[Edge]]
sccCycles Tree Int
t = ([Int] -> Maybe [Edge]) -> [[Int]] -> [[Edge]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Int] -> Maybe [Edge]
addBackEdge (Tree Int -> [[Int]]
forall a. Tree a -> [[a]]
treePaths Tree Int
t)
addBackEdge :: [Vertex] -> Maybe [Edge]
addBackEdge :: [Int] -> Maybe [Edge]
addBackEdge path :: [Int]
path@(Int
root : [Int]
_) =
let back :: Edge
back = ([Int] -> Int
forall a. [a] -> a
last [Int]
path, Int
root) in
if Edge -> [Edge] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Edge
back (Graph -> [Edge]
edges Graph
g) then [Edge] -> Maybe [Edge]
forall a. a -> Maybe a
Just ([Int] -> [Edge]
forall a. [a] -> [(a, a)]
pathEdges ([Int]
path [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
root])) else Maybe [Edge]
forall a. Maybe a
Nothing
treePaths :: Tree a -> [[a]]
treePaths :: Tree a -> [[a]]
treePaths (Node {rootLabel :: forall a. Tree a -> a
rootLabel = a
r, subForest :: forall a. Tree a -> Forest a
subForest = []}) = [[a
r]]
treePaths (Node {rootLabel :: forall a. Tree a -> a
rootLabel = a
r, subForest :: forall a. Tree a -> Forest 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 :: [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 :: (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 Int
root = a -> [a] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex a
failed [a]
packages in
let victims :: [a]
victims = [a] -> (Int -> [a]) -> Maybe Int -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> (Int -> Maybe a) -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe a
vertex) ([Int] -> [a]) -> (Int -> [Int]) -> Int -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> Int -> [Int]
reachable Graph
graph) Maybe Int
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 (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 :: Int -> Maybe a
vertex Int
n = Maybe a -> Int -> Map Int (Maybe a) -> Maybe a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Maybe a
forall a. Maybe a
Nothing Int
n Map Int (Maybe a)
vertexMap
vertexMap :: Map Int (Maybe a)
vertexMap = [(Int, Maybe a)] -> Map Int (Maybe a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Int] -> [Maybe a] -> [(Int, Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
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 :: (a -> a -> Ordering) -> [a] -> [a]
orderSource a -> a -> Ordering
cmp [a]
packages =
(Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> (Int -> Maybe a) -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe a
vertex) (Graph -> [Int]
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 :: Int -> Maybe a
vertex Int
n = Maybe a -> Int -> Map Int (Maybe a) -> Maybe a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Maybe a
forall a. Maybe a
Nothing Int
n Map Int (Maybe a)
vertexMap
vertexMap :: Map Int (Maybe a)
vertexMap = [(Int, Maybe a)] -> Map Int (Maybe a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Int] -> [Maybe a] -> [(Int, Maybe a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
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 :: (a -> a -> Ordering) -> [a] -> Graph
buildGraph a -> a -> Ordering
cmp [a]
packages =
let es :: [Edge]
es = [(a, Int)] -> [Edge]
forall a. [(a, a)] -> [(a, a)]
someEdges ([a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
packages [Int
0..]) in
Edge -> [Edge] -> Graph
buildG (Int
0, [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
packages Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Edge]
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' :: control -> control -> Ordering
compareSource' control
control1 control
control2
| (Relation -> Bool) -> [Relation] -> 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 -> [Relation]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Relations
depends1) = Ordering
GT
| (Relation -> Bool) -> [Relation] -> 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 -> [Relation]
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 :: [String] -> IO [DebianControl]
genDeps [String]
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
<$> (String -> IO DebianControl) -> [String] -> IO [DebianControl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO DebianControl
genDep' [String]
controlFiles
where
genDep' :: String -> IO DebianControl
genDep' String
controlPath = String -> IO (Either ParseError (Control' Text))
forall a.
ControlFunctions a =>
String -> IO (Either ParseError (Control' a))
parseControlFromFile String
controlPath IO (Either ParseError (Control' Text))
-> (Either ParseError (Control' Text) -> IO DebianControl)
-> IO DebianControl
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 [Int
String
Loc :: String -> String -> String -> Edge -> Edge -> Loc
loc_filename :: String
loc_package :: String
loc_module :: String
loc_start :: Edge
loc_end :: Edge
$__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 (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 (m :: * -> *) a. Monad m => a -> m a
return)
getSourceOrder :: FilePath -> IO [SrcPkgName]
getSourceOrder :: String -> IO [SrcPkgName]
getSourceOrder String
fp =
String -> IO [String]
findControlFiles String
fp IO [String]
-> ([String] -> IO [DebianControl]) -> IO [DebianControl]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> IO [DebianControl]
genDeps IO [DebianControl]
-> ([DebianControl] -> IO [SrcPkgName]) -> IO [SrcPkgName]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [SrcPkgName] -> IO [SrcPkgName]
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 :: String -> IO [String]
findControlFiles String
root =
String -> IO [String]
getDirectoryContents String
root IO [String] -> ([String] -> IO [String]) -> IO [String]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(String -> IO String) -> [String] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ String
x -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
root String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/debian/control") IO [String] -> ([String] -> IO [String]) -> IO [String]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist