{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.FileWatch
( WatchMode (WatchModePoll)
, fileWatch
, fileWatchPoll
) where
import Control.Concurrent.STM ( check )
import qualified Data.Map.Merge.Strict as Map
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import GHC.IO.Exception
( IOErrorType (InvalidArgument), IOException (..) )
import Path ( parent )
import Stack.Prelude
import System.FSNotify
( WatchConfig, WatchMode (..), confWatchMode, defaultConfig
, eventPath, watchDir, withManagerConf
)
import System.IO ( getLine )
fileWatch ::
HasTerm env
=> ((Set (Path Abs File) -> IO ()) -> RIO env ())
-> RIO env ()
fileWatch :: forall env.
HasTerm env =>
((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
fileWatch = forall env.
HasTerm env =>
WatchConfig
-> ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
fileWatchConf WatchConfig
defaultConfig
fileWatchPoll ::
HasTerm env
=> ((Set (Path Abs File) -> IO ()) -> RIO env ())
-> RIO env ()
fileWatchPoll :: forall env.
HasTerm env =>
((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
fileWatchPoll =
forall env.
HasTerm env =>
WatchConfig
-> ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
fileWatchConf forall a b. (a -> b) -> a -> b
$ WatchConfig
defaultConfig { confWatchMode :: WatchMode
confWatchMode = Int -> WatchMode
WatchModePoll Int
1000000 }
fileWatchConf ::
HasTerm env
=> WatchConfig
-> ((Set (Path Abs File) -> IO ()) -> RIO env ())
-> RIO env ()
fileWatchConf :: forall env.
HasTerm env =>
WatchConfig
-> ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
fileWatchConf WatchConfig
cfg (Set (Path Abs File) -> IO ()) -> RIO env ()
inner =
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. RIO env a -> IO a
run -> forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf WatchConfig
cfg forall a b. (a -> b) -> a -> b
$ \WatchManager
manager -> do
TVar (Set FilePath)
allFiles <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO forall a. Set a
Set.empty
TVar Bool
dirtyVar <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
True
TVar (Map (Path Abs Dir) (IO ()))
watchVar <- forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO forall k a. Map k a
Map.empty
let onChange :: Event -> m ()
onChange Event
event = forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
Set FilePath
files <- forall a. TVar a -> STM a
readTVar TVar (Set FilePath)
allFiles
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> FilePath
eventPath Event
event forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
files) (forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
dirtyVar Bool
True)
setWatched :: Set (Path Abs File) -> IO ()
setWatched :: Set (Path Abs File) -> IO ()
setWatched Set (Path Abs File)
files = do
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar (Set FilePath)
allFiles forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall b t. Path b t -> FilePath
toFilePath Set (Path Abs File)
files
Map (Path Abs Dir) (IO ())
watch0 <- forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Map (Path Abs Dir) (IO ()))
watchVar
let actions :: Map (Path Abs Dir) (IO (Maybe (IO ())))
actions = forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
(forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing forall {m :: * -> *} {p} {a}.
MonadUnliftIO m =>
p -> m () -> m (Maybe a)
stopListening)
(forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing forall {b} {t}. Path b t -> () -> IO (Maybe (IO ()))
startListening)
(forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched forall {f :: * -> *} {p} {a}.
Applicative f =>
p -> a -> () -> f (Maybe a)
keepListening)
Map (Path Abs Dir) (IO ())
watch0
Map (Path Abs Dir) ()
newDirs
[Map (Path Abs Dir) (IO ())]
watch1 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
Map.toList Map (Path Abs Dir) (IO (Maybe (IO ())))
actions) forall a b. (a -> b) -> a -> b
$ \(Path Abs Dir
k, IO (Maybe (IO ()))
mmv) -> do
Maybe (IO ())
mv <- IO (Maybe (IO ()))
mmv
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
case Maybe (IO ())
mv of
Maybe (IO ())
Nothing -> forall k a. Map k a
Map.empty
Just IO ()
v -> forall k a. k -> a -> Map k a
Map.singleton Path Abs Dir
k IO ()
v
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar (Map (Path Abs Dir) (IO ()))
watchVar forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map (Path Abs Dir) (IO ())]
watch1
where
newDirs :: Map (Path Abs Dir) ()
newDirs = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (, ())
forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList
forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall b t. Path b t -> Path b Dir
parent Set (Path Abs File)
files
keepListening :: p -> a -> () -> f (Maybe a)
keepListening p
_dir a
listen () = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
listen
stopListening :: p -> m () -> m (Maybe a)
stopListening p
_ m ()
f = do
() <- m ()
f forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \IOException
ioe ->
case IOException -> IOErrorType
ioe_type IOException
ioe of
IOErrorType
InvalidArgument -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
IOErrorType
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOException
ioe
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
startListening :: Path b t -> () -> IO (Maybe (IO ()))
startListening Path b t
dir () = do
let dir' :: FilePath
dir' = forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> FilePath
toFilePath Path b t
dir
IO ()
listen <- WatchManager -> FilePath -> ActionPredicate -> Action -> IO (IO ())
watchDir WatchManager
manager FilePath
dir' (forall a b. a -> b -> a
const Bool
True) forall {m :: * -> *}. MonadIO m => Event -> m ()
onChange
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just IO ()
listen
let watchInput :: IO ()
watchInput = do
FilePath
l <- IO FilePath
getLine
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath
l forall a. Eq a => a -> a -> Bool
== FilePath
"quit") forall a b. (a -> b) -> a -> b
$ do
forall a. RIO env a -> IO a
run forall a b. (a -> b) -> a -> b
$ case FilePath
l of
FilePath
"help" -> do
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"help" forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
, FilePath -> StyleDoc
flow FilePath
"display this help."
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"quit" forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
, StyleDoc
"exit."
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"build" forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
, FilePath -> StyleDoc
flow FilePath
"force a rebuild."
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"watched" forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
, FilePath -> StyleDoc
flow FilePath
"display watched files."
]
FilePath
"build" -> forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
dirtyVar Bool
True
FilePath
"watched" -> do
Set FilePath
watch <- forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Set FilePath)
allFiles
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Style -> StyleDoc -> StyleDoc
style Style
File forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => FilePath -> a
fromString) (forall a. Set a -> [a]
Set.toList Set FilePath
watch)
FilePath
"" -> forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
dirtyVar Bool
True
FilePath
_ -> forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ FilePath -> StyleDoc
flow FilePath
"Unknown command:"
, Style -> StyleDoc -> StyleDoc
style Style
Shell (forall a. IsString a => FilePath -> a
fromString FilePath
l) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
, StyleDoc
"Try"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"help" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
IO ()
watchInput
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
race_ IO ()
watchInput forall a b. (a -> b) -> a -> b
$ forall a. RIO env a -> IO a
run forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
Bool
dirty <- forall a. TVar a -> STM a
readTVar TVar Bool
dirtyVar
Bool -> STM ()
check Bool
dirty
Either SomeException ()
eres <- forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny forall a b. (a -> b) -> a -> b
$ (Set (Path Abs File) -> IO ()) -> RIO env ()
inner Set (Path Abs File) -> IO ()
setWatched
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
dirtyVar Bool
False
case Either SomeException ()
eres of
Left SomeException
e ->
case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just ExitCode
ExitSuccess ->
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$ Style -> StyleDoc -> StyleDoc
style Style
Good forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> FilePath
displayException SomeException
e
Maybe ExitCode
_ -> case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e :: Maybe PrettyException of
Just PrettyException
pe -> forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> StyleDoc
pretty PrettyException
pe
Maybe PrettyException
_ -> forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$ Style -> StyleDoc -> StyleDoc
style Style
Error forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> FilePath
displayException SomeException
e
Either SomeException ()
_ -> forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
Style -> StyleDoc -> StyleDoc
style Style
Good (FilePath -> StyleDoc
flow FilePath
"Success! Waiting for next file change.")
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
[ StyleDoc
"Type"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"help"
, FilePath -> StyleDoc
flow FilePath
"for the available commands. Press enter to force a rebuild."
]