{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Rib.Watch
( onTreeChange,
)
where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race)
import Control.Concurrent.Chan
import Path
import Relude
import System.FSNotify (Event (..), watchTreeChan, withManager)
onTreeChange :: Path b t -> ([Event] -> IO ()) -> IO ()
onTreeChange :: Path b t -> ([Event] -> IO ()) -> IO ()
onTreeChange fp :: Path b t
fp f :: [Event] -> IO ()
f = do
(WatchManager -> IO ()) -> IO ()
forall a. (WatchManager -> IO a) -> IO a
withManager ((WatchManager -> IO ()) -> IO ())
-> (WatchManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \mgr :: WatchManager
mgr -> do
Chan Event
eventCh <- IO (Chan Event)
forall a. IO (Chan a)
newChan
IO (IO ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ WatchManager
-> FilePath -> ActionPredicate -> Chan Event -> IO (IO ())
watchTreeChan WatchManager
mgr (Path b t -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b t
fp) (Bool -> ActionPredicate
forall a b. a -> b -> a
const Bool
True) Chan Event
eventCh
IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Event
firstEvent <- Chan Event -> IO Event
forall a. Chan a -> IO a
readChan Chan Event
eventCh
[Event]
events <- Int -> [Event] -> IO Event -> IO [Event]
forall event. Int -> [event] -> IO event -> IO [event]
debounce 100 [Event
firstEvent] (IO Event -> IO [Event]) -> IO Event -> IO [Event]
forall a b. (a -> b) -> a -> b
$ Chan Event -> IO Event
forall a. Chan a -> IO a
readChan Chan Event
eventCh
[Event] -> IO ()
f [Event]
events
debounce :: Int -> [event] -> IO event -> IO [event]
debounce :: Int -> [event] -> IO event -> IO [event]
debounce millies :: Int
millies events :: [event]
events f :: IO event
f = do
IO event -> IO () -> IO (Either event ())
forall a b. IO a -> IO b -> IO (Either a b)
race IO event
f (Int -> IO ()
threadDelay (1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
millies)) IO (Either event ())
-> (Either event () -> IO [event]) -> IO [event]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left event :: event
event ->
Int -> [event] -> IO event -> IO [event]
forall event. Int -> [event] -> IO event -> IO [event]
debounce Int
millies ([event]
events [event] -> [event] -> [event]
forall a. Semigroup a => a -> a -> a
<> [event
event]) IO event
f
Right () ->
[event] -> IO [event]
forall (m :: * -> *) a. Monad m => a -> m a
return [event]
events