{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Hails.FS where
import Prelude hiding (FilePath)
import Control.Concurrent.MVar
import Control.Concurrent (threadDelay, forkIO)
import Control.Monad (forever)
import Data.ReactiveValue
import Filesystem.Path.CurrentOS
import System.Directory
import System.FSNotify
pasiveFileReactive :: FilePath -> ReactiveFieldReadWrite IO String
pasiveFileReactive :: FilePath -> ReactiveFieldReadWrite IO String
pasiveFileReactive FilePath
fp = FieldSetter IO String
-> FieldGetter IO String
-> FieldNotifier IO String
-> ReactiveFieldReadWrite IO String
forall (m :: * -> *) a.
FieldSetter m a
-> FieldGetter m a
-> FieldNotifier m a
-> ReactiveFieldReadWrite m a
ReactiveFieldReadWrite FieldSetter IO String
setter FieldGetter IO String
getter FieldNotifier IO String
forall (m :: * -> *) p. Monad m => p -> m ()
notifier
where getter :: FieldGetter IO String
getter = String -> FieldGetter IO String
readFile (FilePath -> String
encodeString FilePath
fp)
setter :: FieldSetter IO String
setter String
v = String -> FieldSetter IO String
writeFile (FilePath -> String
encodeString FilePath
fp) String
v
notifier :: p -> m ()
notifier p
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
fileReactive :: FilePath -> IO (ReactiveFieldReadWrite IO String)
fileReactive :: FilePath -> IO (ReactiveFieldReadWrite IO String)
fileReactive FilePath
fp = do
String
fpP <- String -> FieldGetter IO String
canonicalizePath (FilePath -> String
encodeString FilePath
fp)
MVar [IO ()]
notifiers <- [IO ()] -> IO (MVar [IO ()])
forall a. a -> IO (MVar a)
newMVar []
let getter :: FieldGetter IO String
getter = String -> FieldGetter IO String
readFile (FilePath -> String
encodeString FilePath
fp)
setter :: FieldSetter IO String
setter String
v = String -> FieldSetter IO String
writeFile (FilePath -> String
encodeString FilePath
fp) String
v
notify :: IO ()
notify = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> IO [IO ()] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MVar [IO ()] -> IO [IO ()]
forall a. MVar a -> IO a
readMVar MVar [IO ()]
notifiers
notifier :: FieldNotifier IO String
notifier IO ()
p = MVar [IO ()] -> ([IO ()] -> IO [IO ()]) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar [IO ()]
notifiers (\[IO ()]
x -> [IO ()] -> IO [IO ()]
forall (m :: * -> *) a. Monad m => a -> m a
return ([IO ()]
x [IO ()] -> [IO ()] -> [IO ()]
forall a. [a] -> [a] -> [a]
++ [IO ()
p]))
IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (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
mgr -> do
IO ()
_ <- WatchManager -> String -> ActionPredicate -> Action -> IO (IO ())
watchDir WatchManager
mgr
(FilePath -> String
encodeString (FilePath -> String) -> FilePath -> String
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
directory FilePath
fp)
(\Event
e -> Event -> String
eventPath Event
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fpP)
(IO () -> Action
forall a b. a -> b -> a
const IO ()
notify)
FieldNotifier IO String
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever FieldNotifier IO String -> FieldNotifier IO String
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound
ReactiveFieldReadWrite IO String
-> IO (ReactiveFieldReadWrite IO String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ReactiveFieldReadWrite IO String
-> IO (ReactiveFieldReadWrite IO String))
-> ReactiveFieldReadWrite IO String
-> IO (ReactiveFieldReadWrite IO String)
forall a b. (a -> b) -> a -> b
$ FieldSetter IO String
-> FieldGetter IO String
-> FieldNotifier IO String
-> ReactiveFieldReadWrite IO String
forall (m :: * -> *) a.
FieldSetter m a
-> FieldGetter m a
-> FieldNotifier m a
-> ReactiveFieldReadWrite m a
ReactiveFieldReadWrite FieldSetter IO String
setter FieldGetter IO String
getter FieldNotifier IO String
notifier