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
data ThreadProc = Haskell (IO ())
| System String
data OneThread = Running UTCTime ThreadId
| Shell UTCTime ProcessHandle
| NotRunning
fork :: ThreadProc -> IO OneThread
fork (Haskell io) = Running <$> getCurrentTime <*> forkIO io
fork (System sh) = Shell <$> getCurrentTime <*> runCommand sh
olderThan :: OneThread -> UTCTime -> Bool
olderThan (Running t0 _) t = t0 < t
olderThan (Shell t0 _) t = t0 < t
olderThan NotRunning _ = True
kill :: OneThread -> IO ()
kill (Running _ t) = killThread t
kill (Shell _ t) = terminateProcess t
kill NotRunning = return ()
forkIfOutdated :: ThreadProc -> OneThread -> UTCTime -> IO OneThread
forkIfOutdated thProc thread time =
if thread `olderThan` time
then kill thread >> fork thProc
else return thread
exists :: FilePath -> IO Bool
exists file = (||) <$> doesFileExist file <*> doesDirectoryExist file
modTime :: String -> IO (Maybe UTCTime)
modTime file = do
e <- exists file
if e
then Just <$> getModificationTime file
else return Nothing
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
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