{-# Language FlexibleInstances #-}

module System.Touched (onChange, onChangeAny) where

import Control.Applicative ((<$>), (<*>))
import Control.Concurrent
import Data.Maybe
import Data.Time.Clock
import System.Directory
import System.Process

class IntoProc a where
  intoProc :: a -> ThreadProc

instance IntoProc [Char] where
  intoProc = System

instance IntoProc (IO ()) where
  intoProc = Haskell

-- | Wrapper around an IO action or a string representing a shell command
-- | to be executed.
data ThreadProc = Haskell (IO ())
                | System String

-- | Calling 'fork' on a ThreadProc returns a 'OneThread', which has the
-- | time it was launched and a reference identifier. Used to kill and
-- | restart a thread on change
data OneThread = Running UTCTime ThreadId
               | Shell UTCTime ProcessHandle
               | NotRunning

-- | Launch a new thread/shell command
fork :: ThreadProc -> IO OneThread
fork (Haskell io) = Running <$> getCurrentTime <*> forkIO io
fork (System sh)  = Shell <$> getCurrentTime <*> runCommand sh

-- | Test if OneThread was launched before a specified UTCTime
olderThan :: OneThread -> UTCTime -> Bool
olderThan (Running t0 _) t = t0 < t
olderThan (Shell t0 _) t = t0 < t
olderThan NotRunning _ = True

-- | Kills a running process.
kill :: OneThread -> IO ()
kill (Running _ t) = killThread t
kill (Shell _ t) = terminateProcess t
kill NotRunning = return ()

-- | Takes a procedure, a running thread, and a time stamp.
-- | If the running thread is older than the timestamp, kill it and launch
-- | the new thread.
forkIfOutdated :: ThreadProc -> OneThread -> UTCTime -> IO OneThread 
forkIfOutdated thProc thread time =
  if thread `olderThan` time
  then kill thread >> fork thProc
  else return thread

-- | Sometimes we don't really care if things are directories or files.
-- | Returns true if a path exists, regardless of type.
exists :: FilePath -> IO Bool
exists file = (||) <$> doesFileExist file <*> doesDirectoryExist file

-- | Last modified time as a total function
modTime :: String -> IO (Maybe UTCTime)
modTime file = do
  e <- exists file
  if e
  then Just <$> getModificationTime file
  else return Nothing

-- | When a file changes, launch a prodecure
onChange :: IntoProc a => FilePath -> a -> IO ()
onChange file action =
  let
    onChange' file action oneTh =
      threadDelay 1000 >>
      modTime file >>=
      maybe (error "File not found.") (forkIfOutdated action oneTh) >>=
      onChange' file action
  in onChange' file (intoProc action) NotRunning

-- | Same as 'onChange', but works if any files in a list have changed
onChangeAny :: IntoProc a => [FilePath] -> a -> IO ()
onChangeAny files action =
  let
    onChangeAny' files action oneTh = do
      threadDelay 1000
      times <- mapM modTime files
      case map fst . filter (isNothing . snd) $ zip files times of
       [] -> forkIfOutdated action oneTh (maximum $ map fromJust times) >>=
             onChangeAny' files action
       xs  -> putStrLn $ "File(s) not found: " ++
              foldl1 (\x y -> x ++ ' ':y) xs
  in onChangeAny' files (intoProc action) NotRunning