{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE OverloadedStrings    #-}
-- |
--
-- Copyright   : (C) Keera Studios Ltd, 2013
-- License     : BSD3
-- Maintainer  : support@keera.co.uk
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

-- | A file as a passive reactive value.
--
-- Passive values are those that never notify of changes to them. They are
-- useful as sources of information controlled by other RVs (buttons, etc.)
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 ()

-- | A file as a reactive value. The file must exist at the time
-- the call is evaluated.

-- TODO: Make it ok for the file not to exist.
-- TODO: Capture and ignore exceptions in readFile and writeFile.
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)   -- fails if the path does not exist
      setter :: FieldSetter IO String
setter String
v   = String -> FieldSetter IO String
writeFile (FilePath -> String
encodeString FilePath
fp) String
v -- may fail
      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]))

  -- Run the notification manager, ignore result (thread)
  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                            -- manager
                  (FilePath -> String
encodeString (FilePath -> String) -> FilePath -> String
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
directory FilePath
fp)  -- directory to watch
                  (\Event
e -> Event -> String
eventPath Event
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fpP)     -- predicate
                  (IO () -> Action
forall a b. a -> b -> a
const IO ()
notify)                 -- notifier
    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