{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Program.Notify (
waitForChange,
) where
import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)
import Control.Monad.IO.Class (liftIO)
import Core.Data.Structures
import Core.Program.Execute
import Core.Program.Logging
import Core.Program.Unlift
import Data.Foldable (foldrM)
import System.Directory (canonicalizePath)
import System.FSNotify (Event (..), eventPath, watchDir, withManager)
import System.FilePath (dropFileName)
waitForChange :: [FilePath] -> Program τ ()
waitForChange :: [FilePath] -> Program τ ()
waitForChange [FilePath]
files =
let f :: FilePath -> Set FilePath -> Set FilePath
f :: FilePath -> Set FilePath -> Set FilePath
f FilePath
path Set FilePath
acc = FilePath -> Set FilePath -> Set FilePath
forall ε. Key ε => ε -> Set ε -> Set ε
insertElement FilePath
path Set FilePath
acc
g :: FilePath -> Set FilePath -> Set FilePath
g :: FilePath -> Set FilePath -> Set FilePath
g FilePath
path Set FilePath
acc = FilePath -> Set FilePath -> Set FilePath
forall ε. Key ε => ε -> Set ε -> Set ε
insertElement (FilePath -> FilePath
dropFileName FilePath
path) Set FilePath
acc
in do
Rope -> Program τ ()
forall τ. Rope -> Program τ ()
info Rope
"Watching for changes"
[FilePath]
canonical <- (FilePath -> Program τ FilePath)
-> [FilePath] -> Program τ [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO FilePath -> Program τ FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> Program τ FilePath)
-> (FilePath -> IO FilePath) -> FilePath -> Program τ FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO FilePath
canonicalizePath) [FilePath]
files
let paths :: Set FilePath
paths = (FilePath -> Set FilePath -> Set FilePath)
-> Set FilePath -> [FilePath] -> Set FilePath
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FilePath -> Set FilePath -> Set FilePath
f Set FilePath
forall ε. Key ε => Set ε
emptySet [FilePath]
canonical
let dirs :: Set FilePath
dirs = (FilePath -> Set FilePath -> Set FilePath)
-> Set FilePath -> [FilePath] -> Set FilePath
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FilePath -> Set FilePath -> Set FilePath
g Set FilePath
forall ε. Key ε => Set ε
emptySet [FilePath]
files
((forall β. Program τ β -> IO β) -> IO ()) -> Program τ ()
forall τ α.
((forall β. Program τ β -> IO β) -> IO α) -> Program τ α
withContext (((forall β. Program τ β -> IO β) -> IO ()) -> Program τ ())
-> ((forall β. Program τ β -> IO β) -> IO ()) -> Program τ ()
forall a b. (a -> b) -> a -> b
$ \forall β. Program τ β -> IO β
runProgram -> do
MVar Bool
block <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar
(WatchManager -> IO ()) -> IO ()
forall a. (WatchManager -> IO a) -> IO a
withManager ((WatchManager -> IO ()) -> IO ())
-> (WatchManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WatchManager
manager -> do
[IO ()]
stoppers <-
(FilePath -> [IO ()] -> IO [IO ()])
-> [IO ()] -> Set FilePath -> IO [IO ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM
( \FilePath
dir [IO ()]
acc -> do
Program τ () -> IO ()
forall β. Program τ β -> IO β
runProgram (Rope -> FilePath -> Program τ ()
forall α τ. Show α => Rope -> α -> Program τ ()
debugS Rope
"watching" FilePath
dir)
IO ()
stopper <-
WatchManager -> FilePath -> ActionPredicate -> Action -> IO (IO ())
watchDir
WatchManager
manager
FilePath
dir
( \Event
trigger -> case Event
trigger of
Modified FilePath
file UTCTime
_ Bool
_ -> do
if FilePath -> Set FilePath -> Bool
forall ε. Key ε => ε -> Set ε -> Bool
containsElement FilePath
file Set FilePath
paths
then Bool
True
else Bool
False
Event
_ -> Bool
False
)
( \Event
trigger -> do
Program τ () -> IO ()
forall β. Program τ β -> IO β
runProgram (Rope -> FilePath -> Program τ ()
forall α τ. Show α => Rope -> α -> Program τ ()
debugS Rope
"trigger" (Event -> FilePath
eventPath Event
trigger))
MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
block Bool
False
)
[IO ()] -> IO [IO ()]
forall (m :: * -> *) a. Monad m => a -> m a
return (IO ()
stopper IO () -> [IO ()] -> [IO ()]
forall a. a -> [a] -> [a]
: [IO ()]
acc)
)
[]
Set FilePath
dirs
Bool
_ <- MVar Bool -> IO Bool
forall a. MVar a -> IO a
readMVar MVar Bool
block
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
stoppers
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Rational -> Program τ ()
forall τ. Rational -> Program τ ()
sleepThread Rational
0.1