{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Stack.FileWatch
( fileWatch
, fileWatchPoll
) where
import Control.Concurrent.STM (check)
import Stack.Prelude
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import GHC.IO.Exception
import Path
import System.FSNotify
import System.IO (getLine)
import RIO.PrettyPrint hiding (line)
fileWatch
:: (HasLogFunc env, HasTerm env)
=> ((Set (Path Abs File) -> IO ()) -> RIO env ())
-> RIO env ()
fileWatch = fileWatchConf defaultConfig
fileWatchPoll
:: (HasLogFunc env, HasTerm env)
=> ((Set (Path Abs File) -> IO ()) -> RIO env ())
-> RIO env ()
fileWatchPoll = fileWatchConf $ defaultConfig { confUsePolling = True }
fileWatchConf
:: (HasLogFunc env, HasTerm env)
=> WatchConfig
-> ((Set (Path Abs File) -> IO ()) -> RIO env ())
-> RIO env ()
fileWatchConf cfg inner = withRunInIO $ \run -> withManagerConf cfg $ \manager -> do
allFiles <- newTVarIO Set.empty
dirtyVar <- newTVarIO True
watchVar <- newTVarIO Map.empty
let onChange event = atomically $ do
files <- readTVar allFiles
when (eventPath event `Set.member` files) (writeTVar dirtyVar True)
setWatched :: Set (Path Abs File) -> IO ()
setWatched files = do
atomically $ writeTVar allFiles $ Set.map toFilePath files
watch0 <- readTVarIO watchVar
let actions = Map.mergeWithKey
keepListening
stopListening
startListening
watch0
newDirs
watch1 <- forM (Map.toList actions) $ \(k, mmv) -> do
mv <- mmv
return $
case mv of
Nothing -> Map.empty
Just v -> Map.singleton k v
atomically $ writeTVar watchVar $ Map.unions watch1
where
newDirs = Map.fromList $ map (, ())
$ Set.toList
$ Set.map parent files
keepListening _dir listen () = Just $ return $ Just listen
stopListening = Map.map $ \f -> do
() <- f `catch` \ioe ->
case ioe_type ioe of
InvalidArgument -> return ()
_ -> throwIO ioe
return Nothing
startListening = Map.mapWithKey $ \dir () -> do
let dir' = fromString $ toFilePath dir
listen <- watchDir manager dir' (const True) onChange
return $ Just listen
let watchInput = do
line <- getLine
unless (line == "quit") $ do
run $ case line of
"help" -> do
logInfo ""
logInfo "help: display this help"
logInfo "quit: exit"
logInfo "build: force a rebuild"
logInfo "watched: display watched files"
"build" -> atomically $ writeTVar dirtyVar True
"watched" -> do
watch <- readTVarIO allFiles
mapM_ (logInfo . fromString) (Set.toList watch)
"" -> atomically $ writeTVar dirtyVar True
_ -> logInfo $
"Unknown command: " <>
displayShow line <>
". Try 'help'"
watchInput
race_ watchInput $ run $ forever $ do
atomically $ do
dirty <- readTVar dirtyVar
check dirty
eres <- tryAny $ inner setWatched
atomically $ writeTVar dirtyVar False
prettyInfo $
case eres of
Left e ->
let theStyle = case fromException e of
Just ExitSuccess -> Good
_ -> Error
in style theStyle $ fromString $ show e
_ -> style Good "Success! Waiting for next file change."
logInfo "Type help for available commands. Press enter to force a rebuild."