{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Program.Notify
(
waitForChange
) where
import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)
import Data.Foldable (foldr, foldrM)
import System.FilePath (dropFileName)
import System.FSNotify (Event(..), withManager, watchDir, eventPath)
import Core.Data.Structures
import Core.Program.Execute
import Core.Program.Logging
import Core.Program.Unlift
import System.Directory (canonicalizePath)
import Control.Monad.IO.Class (liftIO)
waitForChange :: [FilePath] -> Program τ ()
waitForChange files =
let
f :: FilePath -> Set FilePath -> Set FilePath
f path acc = insertElement path acc
g :: FilePath -> Set FilePath -> Set FilePath
g path acc = insertElement (dropFileName path) acc
in do
event "Watching for changes"
canonical <- mapM (liftIO . canonicalizePath) files
let paths = foldr f emptySet canonical
let dirs = foldr g emptySet files
withContext $ \runProgram -> do
block <- newEmptyMVar
withManager $ \manager -> do
stoppers <- foldrM (\dir acc -> do
runProgram (debugS "watching" dir)
stopper <- watchDir manager dir
(\trigger -> case trigger of
Modified file _ _ -> do
if containsElement file paths
then True
else False
_ -> False
)
(\trigger -> do
runProgram (debugS "trigger" (eventPath trigger))
putMVar block False
)
return (stopper:acc)) [] dirs
_ <- readMVar block
sequence_ stoppers
return ()
sleep 0.1