-- File created: 2008-09-20 12:28:56

module Coadjute.Task.Required (splitUnnecessary) where

import Control.Monad        (foldM, when)
import Control.Monad.State  (get, put, StateT, runStateT)
import Data.Graph.Inductive (labNodes, delNodes)
import Data.Maybe           (fromJust, isJust, isNothing)
import Data.Set             (Set)
import qualified Data.Set as Set
import System.Directory     (getModificationTime)
import System.Time          (ClockTime)

import Coadjute.CoData
import Coadjute.DB         ( MDB, DB (hasHashes), addEntry
                           , Datum, dbLookup, hasHash, dArgs)
import Coadjute.Hash       (Hash, hashFile)
import Coadjute.Task       (TaskGraph, Task(..), Target)
import Coadjute.Util.File  (allPathsExist)
import Coadjute.Util.Monad (anyM)

-- |Returns a (targets to be built, up to date targets, database) triple.
--
-- The database is updated here, because we may need to hash here to decide
-- whether something needs to be built. Thus if we would not do updating here,
-- we would need to rehash something later on.
--
-- It's possible that some tasks are removed from the 'to be run' list later,
-- but Datums for them are generated here anyway. Such should be removed by the
-- caller to keep the DB slim.
splitUnnecessary :: MDB -> TaskGraph -> CoData (TaskGraph, [Task], MDB)
splitUnnecessary mdb gr =
   let tNodes = labNodes gr
       tasks  = map snd tNodes
       f = do
          usingDB <- asks coUsingDB
          if usingDB && isJust mdb
             then do
                let db = fromJust mdb
                checkDep <- selectCheckDepFunc db
                (needs,db') <-
                   foldM (needsBuildingWithDB checkDep) ([],db) tasks

                return (reverse needs, Just db')
             else do
                needs <- io$ mapM needsBuildingWithoutDB tasks
                return (needs, mdb)
    in do
       (needs, mdb') <- f
       let (upToDateNodes, upToDateTasks) =
              unzip . map snd . filter (not.fst) $ zip needs tNodes
       return (delNodes upToDateNodes gr, upToDateTasks, mdb')

-- This needs to be lazy, which is why we use anyM.
-- (needsBuildingByTimeStamp throws if a target does not exist)
needsBuildingWithoutDB :: Task -> IO Bool
needsBuildingWithoutDB t =
   anyM ($t) [needsBuildingByExistence, needsBuildingByTimeStamp]

-- Do any targets not exist
needsBuildingByExistence :: Task -> IO Bool
needsBuildingByExistence = fmap not . allPathsExist . tTargets

-- Is any target outdated
needsBuildingByTimeStamp :: Task -> IO Bool
needsBuildingByTimeStamp t = do
   oldest <- getOldestModTime (tTargets t)
   anyM (fmap (> oldest) . getModificationTime) (tDeps t)

getOldestModTime :: [Target] -> IO ClockTime
getOldestModTime = fmap minimum . mapM getModificationTime

needsBuildingWithDB :: (Task -> Bool -> IO CheckDepFunc)
                    -> ([Bool],DB) -> Task -> CoData ([Bool],DB)
needsBuildingWithDB getCDF (ns,db) task = do
   targetsMissing <- io$ needsBuildingByExistence task

   -- Can't short circuit due to targetsMissing: we need to add entries to the
   -- database even if it's True.

   checkDep <- io$ getCDF task targetsMissing

   givenArgs <- asks coArgs
   let caresAboutArgs = tArgs task

   -- we need to write all Datums to the DB if args differ and even one
   -- dependency needs to be rebuilt
   -- at least for now, just use foldM and thus always write them all
   (need, db') <-
      foldM (checkDep (givenArgs `Set.intersection` caresAboutArgs)
                      caresAboutArgs)
            targetsMissing
            (tDeps task) `runStateT` db

   return (need:ns, db')

-- useHash and useTimeStamp are two alternative functions used in
-- needsBuildingWithDB. They are applied to each dependency of a Task,
-- returning True if that dependency causes the Task to need a rebuild, and
-- modifying the database with new information about the dependency if
-- necessary.

type CheckDepFunc = Set String -> Set String
                 -> Bool
                 -> FilePath
                 -> StateT DB CoData Bool

selectCheckDepFunc :: DB -> CoData (Task -> Bool -> IO CheckDepFunc)
selectCheckDepFunc db = do
   forceNoHash <- asks coForceNoHash
   let hashing = not forceNoHash && hasHashes db

   if hashing
      then return$ \_ _ -> return useHash
      else return$ \task targetsMissing ->
         if targetsMissing
            then return (useTimeStamp Nothing)
            else do
               mt <- io.getOldestModTime.tTargets $ task
               return (useTimeStamp (Just mt))

useHash :: CheckDepFunc
useHash givenCareArgs caresAboutArgs othersNeeds source = do
   hash <- io $ hashFile source
   db   <- get
   old  <- checkNewness db source givenCareArgs (Just hash)
   case old of
        Nothing -> return othersNeeds
        Just o  ->
           if o `hasHash` hash &&
              argsMatch givenCareArgs caresAboutArgs (dArgs o)

              then return othersNeeds
              else do put$ addEntry db source givenCareArgs (Just hash)
                      return True

useTimeStamp :: Maybe ClockTime -> CheckDepFunc
useTimeStamp oldestMod givenCareArgs caresAboutArgs othersNeeds source = do
   db  <- get
   old <- checkNewness db source givenCareArgs Nothing
   case old of
        Nothing -> checkTime
        Just o  ->
           if argsMatch givenCareArgs caresAboutArgs (dArgs o)
              then checkTime
              else do
                 put$ addEntry db source givenCareArgs Nothing
                 return True
 where
   -- Note that the fromJust may error out if othersNeeds is True, which is why
   -- we short-circuit.
   --
   -- (The initial value of oldestMod, set in selectCheckDepFunc, is Nothing if
   -- targetsMissing, the initial value of othersNeeds, is True.)
   checkTime
      | othersNeeds = return True
      | otherwise   =
         fmap (> fromJust oldestMod) (io$ getModificationTime source)

-- If the entry isn't already in the DB, add it.
-- Returns Just (the old entry) or Nothing.
checkNewness :: DB -> FilePath -> Set String -> Maybe Hash
             -> StateT DB CoData (Maybe Datum)

checkNewness db file givenArgs mhash = do
   let entry = dbLookup db file
   when (isNothing entry) $
      put$ addEntry db file givenArgs mhash
   return entry

argsMatch :: Set String -> Set String -> Set String -> Bool
argsMatch givenCareArgs caresAboutArgs builtWithArgs =
   givenCareArgs == builtWithArgs `Set.intersection` caresAboutArgs