module Coadjute.Task(
Source, Target,
Task(..), showTask, sameTarget,
TaskGraph,
splitImpossibles, splitCycles
) where
import Control.Exception (assert)
import Control.Monad (filterM)
import Data.Graph.Inductive (Gr, delNodes, lab, scc, mkGraph)
import Data.List (findIndex)
import Data.Maybe (fromJust)
import Data.Set (Set)
import qualified Data.Set as Set
import Coadjute.CoData
import Coadjute.Util.File (allPathsExist)
import Coadjute.Util.List (length1)
type Source = FilePath
type Target = FilePath
data Task =
Task {
tName :: String,
tArgs :: Set String,
tTargets :: [Target],
tDeps :: [Source],
tAction :: IO ()
}
showTask :: Task -> String
showTask Task {tTargets = t, tDeps = d, tArgs = a} =
concat
[ "Task { tTargets = ", show t
, ", tDeps = ", show d
, ", tArgs = ", show a
, " }"
]
sameTarget :: Task -> Task -> Bool
sameTarget (Task {tTargets=ts}) (Task {tTargets=tz}) = any (`elem` ts) tz
(=~=), (!~=) :: Task -> Task -> Bool
Task {tName = n, tTargets = t, tDeps = d}
=~= Task {tName = n', tTargets = t', tDeps = d'} =
assert
(t /= t' || (n == n' && d == d'))
(t == t')
x !~= y = not (x =~= y)
type TaskGraph = Gr Task ()
splitImpossibles :: [Task] -> CoData ([Task], [Task])
splitImpossibles ts = do
let targets = concatMap tTargets ts
deps = map (\t -> (t, tDeps t)) ts
untargetedDeps = filter (any (`notElem` targets) . snd) deps
impossibleDeps <- io$ filterM (fmap not.allPathsExist.snd) untargetedDeps
let impossibleTasks = map fst impossibleDeps
return (filter (\x -> all (!~= x) impossibleTasks) ts, impossibleTasks)
splitCycles :: [Task] -> (TaskGraph, [[Task]])
splitCycles tasks = (delNodes (concat cycleNodes) graph, cycles)
where
pairs = toPairs tasks
edges = toEdges tasks pairs
graph = mkGraph (zip [0..] tasks) edges
cycleNodes = filter (not.length1) . scc $ graph
cycles = (map.map) (fromJust . lab graph) cycleNodes
toPairs :: [Task] -> [(Task, [Task])]
toPairs tasks = map (\t -> (t, findDependencies t)) tasks
where
findDependencies :: Task -> [Task]
findDependencies task = filter (`targets` (tDeps task)) tasks
targets :: Task -> [Source] -> Bool
targets (Task {tTargets = ts}) = any (`elem` ts)
toEdges :: [Task] -> [(Task, [Task])] -> [(Int, Int, ())]
toEdges tasks pairs =
let toIndex t = fromJust $ findIndex (=~= t) tasks
in concatMap
(\(target, deps) ->
let tarIdx = toIndex target
in map (\dep -> (toIndex dep, tarIdx, ())) deps)
pairs