{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TemplateHaskell #-}
{-# LANGUAGE NoDisambiguateRecordFields, NoRecordWildCards #-}
-- |Figure out the dependency relation between debianized source
-- directories.  The code to actually solve these dependency relations
-- for a particular set of binary packages is in Debian.Repo.Dependency.
module Debian.GenBuildDeps
    ( DepInfo(..)
    , sourceName'
    , relations'
    , binaryNames'
    -- * Preparing dependency info
    , buildDependencies
    , RelaxInfo
    , relaxDeps
    -- * Using dependency info
    , BuildableInfo(..)
    , ReadyTarget(..)
    , buildable
    , compareSource
    -- * Obsolete?
    , 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           Debug.Trace (trace)
import           System.Directory (getDirectoryContents, doesFileExist)

-- | This type describes the build dependencies of a source package.
data DepInfo = DepInfo {
      DepInfo -> SrcPkgName
sourceName :: SrcPkgName          -- ^ source package name
    , DepInfo -> Relations
relations :: Relations            -- ^ dependency relations
    , DepInfo -> [BinPkgName]
binaryNames :: [BinPkgName]       -- ^ binary dependency names (is this a function of relations?)
    , DepInfo -> Set BinPkgName
depSet :: Set.Set BinPkgName          -- ^ Set containing all binary package names mentioned in relations
    , DepInfo -> Set BinPkgName
binSet :: Set.Set BinPkgName          -- ^ Set containing binaryNames
    } 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)

-- |Return the dependency info for a source package with the given dependency relaxation.
-- |According to debian policy, only the first paragraph in debian\/control can be a source package
-- <http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-sourcecontrolfiles>
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 }

-- | source package name
sourceName' :: HasDebianControl control => control -> SrcPkgName
sourceName' :: control -> SrcPkgName
sourceName' control
control = control -> SrcPkgName
forall a. HasDebianControl a => a -> SrcPkgName
debianSourcePackageName control
control

-- | dependency relations
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)]

-- | binary dependency names (is this a function of relations?)
binaryNames' :: HasDebianControl control => control -> [BinPkgName]
binaryNames' :: control -> [BinPkgName]
binaryNames' control
control = control -> [BinPkgName]
forall a. HasDebianControl a => a -> [BinPkgName]
debianBinaryPackageNames control
control

-- |Specifies build dependencies that should be ignored during the build
-- decision.  If the pair is (BINARY, Nothing) it means the binary package
-- BINARY should always be ignored when deciding whether to build.  If the
-- pair is (BINARY, Just SOURCE) it means that binary package BINARY should
-- be ignored when deiciding whether to build package SOURCE.
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

-- | Given a source package name and a binary package name, return
-- False if the binary package should be ignored hwen deciding whether
-- to build the source package.  This is used to prevent build
-- dependency cycles from triggering unnecessary rebuilds.  (This is a
-- replacement for the RelaxInfo type, which we temporarily rename
-- OldRelaxInfo.)
type RelaxInfo = SrcPkgName -> BinPkgName -> Bool

-- |Remove any dependencies that are designated \"relaxed\" by relaxInfo.
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
            -- Discard any dependencies not on the filtered package name list.  If
            -- this results in an empty list in an or-dep the entire dependency can
            -- be discarded.
            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
                  -- ^ Some target whose build dependencies are all satisfied
                  , ReadyTarget a -> [a]
waiting :: [a]
                  -- ^ The targets that are waiting for the ready target
                  , ReadyTarget a -> [a]
other :: [a]
                  -- ^ The rest of the targets that need to be built
                  }

data BuildableInfo a
    = BuildableInfo
      { BuildableInfo a -> [ReadyTarget a]
readyTargets :: [ReadyTarget a]
      , BuildableInfo a -> [a]
allBlocked :: [a] }
    | CycleInfo
      { BuildableInfo a -> [(a, a)]
depPairs :: [(a, a)] }

-- | Given an ordering function representing the dependencies on a
-- list of packages, return a ReadyTarget triple: One ready package,
-- the packages that depend on the ready package directly or
-- indirectly, and all the other packages.
buildable :: forall a. (a -> DepInfo) -> [a] -> BuildableInfo a
buildable :: (a -> DepInfo) -> [a] -> BuildableInfo a
buildable a -> DepInfo
relax [a]
packages =
    -- Find all packages which can't reach any other packages in the
    -- graph of the "has build dependency" relation on the
    -- yet-to-be-built 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
      -- None of the packages are buildable, return information
      -- about how to break this build dependency cycle.
      ([], [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)}
      -- We have some buildable packages, return them along with
      -- the list of packages each one directly blocks
      ([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) }
      --allDeps x = (ofVertex x, List.map ofVertex (filter (/= x) (reachable hasDep x)))
      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
                           -- trace ("compareSource " ++ show (unSrcPkgName $ sourceName xa) ++ " " ++ show (unSrcPkgName $ sourceName ya) ++ " -> " ++ show r') (return ())
                           (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

-- | Find a cycle in a graph that involves
allCycles :: Graph -> [[Edge]]
allCycles :: Graph -> [[Edge]]
allCycles Graph
g =
    -- Every cycle is confined to an SCC (strongly connected component).
    -- Every node in an SCC is part of some cycle.
    (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
      -- Find all the cycles in an SCC
      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

-- | All the paths from root to a leaf
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]
_ = []

-- | Remove any packages which can't be built given that a package has failed.
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))

-- | Given a list of packages, sort them according to their apparant
-- build dependencies so that the first element doesn't depend on any
-- of the other 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))

-- | Build a graph with the list of packages as its nodes and the
-- build dependencies as its edges.
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)

-- |This is a nice start. It ignores circular build depends and takes
-- a pretty simplistic approach to 'or' build depends. However, I
-- think this should work pretty nicely in practice.
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

-- |Return the dependency info for a list of control files.
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
      -- Parse the control file and extract the build dependencies
      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 {- `mapExn` (pushLoc $__LOC__) -} 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)

-- pushLoc :: Loc -> ControlFileError -> ControlFileError
-- pushLoc loc e = e {locs = loc : locs e}

-- |One example of how to tie the below functions together. In this
-- case 'fp' is the path to a directory that contains a bunch of
-- checked out source packages. The code will automatically look for
-- debian\/control. It returns a list with the packages in the
-- order they should be built.
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
      -- Return a list of the files that look like debian\/control.
      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