FileListener.hs

{-# LANGUAGE BangPatterns    #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE RecordWildCards #-}

module Halive.FileListener where

import           Control.Concurrent
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Monad
import           Control.Monad.Trans
import           Data.IORef
import           Data.List              (isInfixOf)
import           Data.Time
import           System.Directory
import           System.FilePath
import           System.FSNotify        hiding (Event)
import qualified System.FSNotify        as FSNotify

type FileEventChan = TChan FSNotify.Event

data ShouldReadFile = ReadFileOnEvents | JustReportEvents deriving (Eq, Show)

data FileEventListener = FileEventListener
    { felEventTChan           :: TChan (Either FSNotify.Event String)
    , felIgnoreNextEventsNear :: TVar (Maybe UTCTime)
    , felStopMVar             :: MVar ()
    }

atomicallyIO :: MonadIO m => STM a -> m a
atomicallyIO = liftIO . atomically

readTChanIO :: MonadIO m => TChan a -> m a
readTChanIO = atomicallyIO . readTChan

writeTChanIO :: MonadIO m => TChan a -> a -> m ()
writeTChanIO chan = atomicallyIO . writeTChan chan

tryReadTChanIO :: MonadIO m => TChan a -> m (Maybe a)
tryReadTChanIO = atomicallyIO . tryReadTChan

peekTChanIO :: MonadIO m => TChan a -> m a
peekTChanIO = atomicallyIO . peekTChan

exhaustTChan :: TChan a -> STM [a]
exhaustTChan chan = unfoldM (tryReadTChan chan)

exhaustTChanIO :: MonadIO m => TChan a -> m [a]
exhaustTChanIO = atomicallyIO . exhaustTChan

-- A version of exhaustTChan that blocks until there is something to read
waitExhaustTChan :: TChan a -> STM [a]
waitExhaustTChan chan = peekTChan chan >> exhaustTChan chan

waitExhaustTChanIO :: MonadIO m => TChan a -> m [a]
waitExhaustTChanIO = atomicallyIO . waitExhaustTChan

-- | Take a monadic stream returning Maybes and
-- pull a list from it until it returns Nothing
unfoldM :: Monad m => m (Maybe a) -> m [a]
unfoldM f = f >>= \case
    Just a  -> (a:) <$> unfoldM f
    Nothing -> return []

fileModifiedPredicate :: FilePath -> FSNotify.Event -> Bool
fileModifiedPredicate fileName event = case event of
    Modified path _ _ -> path == fileName
    Added    path _ _ -> path == fileName
    _                 -> False

-- Returns True if the event filepath is a common editor file
isACommonEditorFile :: FSNotify.Event -> Bool
isACommonEditorFile event = case event of
    Modified path _ _ -> any (`isInfixOf` path) emacsFragments
    _                 -> False
  where emacsFragments = ["#", "flymake", "flycheck"]

eventListenerForFile :: MonadIO m => FilePath -> ShouldReadFile -> m FileEventListener
eventListenerForFile fileName shouldReadFile = liftIO $ do
    eventChan        <- newTChanIO
    ignoreEventsNear <- newTVarIO Nothing

    stopMVar <- forkFileListenerThread fileName shouldReadFile eventChan ignoreEventsNear

    return FileEventListener
        { felEventTChan = eventChan
        , felIgnoreNextEventsNear = ignoreEventsNear
        , felStopMVar = stopMVar
        }

eventListenerForDirectory :: MonadIO m => FilePath -> [String] -> m FileEventListener
eventListenerForDirectory watchDirectory fileTypes = liftIO $ do
    eventChan        <- newTChanIO
    ignoreEventsNear <- newTVarIO Nothing

    stopMVar <- forkDirectoryListenerThread watchDirectory fileTypes eventChan

    return FileEventListener
        { felEventTChan = eventChan
        , felIgnoreNextEventsNear = ignoreEventsNear
        , felStopMVar = stopMVar
        }

killFileEventListener :: MonadIO m => FileEventListener -> m ()
killFileEventListener eventListener = liftIO $ putMVar (felStopMVar eventListener) ()

-- Pass a list like ["hs", "pd", "frag", "vert"] to match only those filetypes,
-- or an empty list to match all
modifiedWithExtensionPredicate :: [String] -> FSNotify.Event -> Bool
modifiedWithExtensionPredicate fileTypes event = case event of
    Modified path _ _ -> null fileTypes || drop 1 (takeExtension path) `elem` fileTypes
    _                 -> False

forkDirectoryListenerThread :: FilePath
                            -> [String]
                            -> TChan (Either FSNotify.Event String)
                            -> IO (MVar ())
forkDirectoryListenerThread watchDirectory fileTypes eventChan = do
    let predicate e = modifiedWithExtensionPredicate fileTypes e
                      && not (isACommonEditorFile e)

    -- Configures debounce time for fsnotify
    let watchConfig = defaultConfig
            { confDebounce = Debounce 0.1 }
    stopMVar <- newEmptyMVar
    _ <- forkIO . withManagerConf watchConfig $ \manager -> do

        stop <- watchTree manager watchDirectory predicate $ \e ->
            writeTChanIO eventChan (Left e)
        () <- takeMVar stopMVar
        stop
    return stopMVar

forkFileListenerThread :: FilePath
                       -> ShouldReadFile
                       -> TChan (Either FSNotify.Event String)
                       -> TVar (Maybe UTCTime)
                       -> IO (MVar ())
forkFileListenerThread fileName shouldReadFile eventChan ignoreEventsNear = do
    leftPredicate <- fileModifiedPredicate <$> canonicalizePath fileName
    let predicate e = leftPredicate e && not (isACommonEditorFile e)
    -- If an ignore time is set, ignore file changes for the next 100 ms
        ignoreTime = 0.1
    -- Configures debounce time for fsnotify
        watchConfig = defaultConfig
            { confDebounce = Debounce 0.1 }

    stopMVar <- newEmptyMVar
    _ <- forkIO . withManagerConf watchConfig $ \manager -> do
        let watchDirectory = takeDirectory fileName

        stop <- watchTree manager watchDirectory predicate $ \e -> do
            mTimeToIgnore <- atomically $ readTVar ignoreEventsNear
            let timeOfEvent = eventTime e
                shouldIgnore = case mTimeToIgnore of
                    Nothing -> False
                    Just timeToIgnore -> abs (timeOfEvent `diffUTCTime` timeToIgnore) < ignoreTime
            unless shouldIgnore $ do
                if (shouldReadFile == ReadFileOnEvents)
                    then do
                        fileContents <- readFile fileName
                            `catch` (\err -> do
                                putStrLn $
                                    "Event listener failed to read " ++ fileName ++
                                    ": " ++ show (err::SomeException)
                                return "")
                        let !_len = length fileContents
                        writeTChanIO eventChan (Right fileContents)
                    else writeTChanIO eventChan (Left e)

        () <- takeMVar stopMVar
        stop
    return stopMVar

setIgnoreTimeNow :: MonadIO m => FileEventListener -> m ()
setIgnoreTimeNow fileEventListener = setIgnoreTime fileEventListener =<< liftIO getCurrentTime

setIgnoreTime :: MonadIO m => FileEventListener -> UTCTime -> m ()
setIgnoreTime FileEventListener{..} time = void . liftIO . atomically $ writeTVar felIgnoreNextEventsNear (Just time)

readFileEvent :: MonadIO m => FileEventListener -> m (Either FSNotify.Event String)
readFileEvent FileEventListener{..} = readTChanIO felEventTChan

onFileEvent :: MonadIO m => FileEventListener -> m () -> m ()
onFileEvent FileEventListener{..} = onTChanRead felEventTChan

onTChanRead :: MonadIO m => TChan a -> m () -> m ()
onTChanRead eventChan action =
    tryReadTChanIO eventChan >>= \case
        Just _  -> action
        Nothing -> return ()

-- | Creates a getter for a set of resources that will be rebuilt whenever the file changes.
-- Takes a filename and an action to create a resource based on that file.
-- getWatchedResource <- makeWatchedResource "resources/shapes.frag" $ do
--        shader <- createShaderProgram "resources/shapes.vert" "resources/shapes.frag"
--        useProgram shader
--
--        uTime       <- getShaderUniform shader "uTime"
--
--        (quadVAO, quadVertCount) <- makeScreenSpaceQuad shader
--        return (quadVAO, quadVertCount, uTime)
-- Then use
-- (quadVAO, quadVertCount, uResolution, uMouse, uTime) <- getWatchedResource
-- in main loop
makeWatchedResource :: FilePath -> IO a -> IO (IO a)
makeWatchedResource fileName action = do
    absFileName <- makeAbsolute fileName
    listener <- eventListenerForFile absFileName JustReportEvents

    resourceRef <- newIORef =<< action

    -- Checks event listener, rebuilds resource if needed,
    -- then returns newest version of resource
    let getWatchedResource = do
            onFileEvent listener $ writeIORef resourceRef =<< action
            readIORef resourceRef
    return getWatchedResource