-- File created: 2008-01-20 13:56:21

module Coadjute.Main (coadjute) where

import Control.Monad        (when)
import Data.Function        (on)
import Data.Graph.Inductive (noNodes)
import Text.Printf          (printf)

import Coadjute.CoData
import Coadjute.DB            (loadDataBase, writeDataBase)
import Coadjute.Rule          (Coadjute, runCoadjute, rTasks)
import Coadjute.Task
import Coadjute.Task.Perform  (performTasks)
import Coadjute.Task.Required (splitUnnecessary)
import Coadjute.Util.List     (fullGroupBy, nubSplitBy)

coadjute :: Coadjute a -> IO a
coadjute st = runCoData $ do
   verbosity <- asks coVerbosity

   (rules,ret) <- runCoadjute st

   -- TODO: allow selection of rules to be applied with cmdline args
   let allTasks = concatMap rTasks rules

   db <- loadDataBase

   let (reasonableTasks, conflicts) = nubSplitBy sameTarget allTasks
   putTaskGroups "Conflicting rules:" conflicts

   (possibleTasks, impossibles) <- splitImpossibles reasonableTasks
   putTasks "Unsatisfiable dependencies:" impossibles

   let (doableTaskGraph, cycles) = splitCycles possibleTasks
   putTaskGroups "Cycles in rules:" cycles

   when (verbosity >= Verbose).io $
      printf "Built graph containing %d possible tasks.\n"
             (noNodes doableTaskGraph)

   (finalTaskGraph,pointless,db') <- splitUnnecessary db doableTaskGraph

   when (verbosity >= Verbose).io $
      printf "%d tasks are unnecessary.\n"
             (noNodes doableTaskGraph - noNodes finalTaskGraph)

   when (verbosity >= VeryVerbose) $
      putTasks "Unnecessary tasks:" pointless

   performTasks finalTaskGraph

   writeDataBase db'

   return ret

putTaskGroups :: MonadIO m => String -> [[Task]] -> m ()
putTaskGroups _ [] = return ()
putTaskGroups s xs = do
   io$ putStrLn s
   mapM_ putTasks' xs

putTasks :: MonadIO m => String -> [Task] -> m ()
putTasks _ [] = return ()
putTasks s xs = do
   io$ putStrLn s
   putTasks' xs

putTasks' :: MonadIO m => [Task] -> m ()
putTasks' [] = return ()
putTasks' xs = io$
   mapM_
      (\ts -> do
         putStrLn $ "\tIn rule '" ++ tName (head ts) ++ "':"
         mapM_ (putStrLn.("\t\t"++).showTask) ts
      )
      (fullGroupBy ((==) `on` tName) xs)