{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Filesystem watching using fsnotify
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)

-- | Recursively monitor the contents of the given path and invoke the given IO
-- action for every event triggered.
--
-- If multiple events fire rapidly, the IO action is invoked only once, taking
-- those multiple events as its argument.
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
  -- Race the readEvent against the timelimit.
  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 ->
      -- If the read event finishes first try again.
      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 () ->
      -- Otherwise continue
      [event] -> IO [event]
forall (m :: * -> *) a. Monad m => a -> m a
return [event]
events