{-# 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 :: ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
fileWatch = WatchConfig
-> ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
forall env.
(HasLogFunc env, HasTerm env) =>
WatchConfig
-> ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
fileWatchConf WatchConfig
defaultConfig

fileWatchPoll
  :: (HasLogFunc env, HasTerm env)
  => ((Set (Path Abs File) -> IO ()) -> RIO env ())
  -> RIO env ()
fileWatchPoll :: ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
fileWatchPoll = WatchConfig
-> ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
forall env.
(HasLogFunc env, HasTerm env) =>
WatchConfig
-> ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
fileWatchConf (WatchConfig
 -> ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ())
-> WatchConfig
-> ((Set (Path Abs File) -> IO ()) -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ WatchConfig
defaultConfig { confUsePolling :: Bool
confUsePolling = Bool
True }

-- | Run an action, watching for file changes
--
-- The action provided takes a callback that is used to set the files to be
-- watched. When any of those files are changed, we rerun the action again.
fileWatchConf
  :: (HasLogFunc env, HasTerm env)
  => WatchConfig
  -> ((Set (Path Abs File) -> IO ()) -> RIO env ())
  -> RIO env ()
fileWatchConf :: WatchConfig
-> ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
fileWatchConf WatchConfig
cfg (Set (Path Abs File) -> IO ()) -> RIO env ()
inner = ((forall a. RIO env a -> IO a) -> IO ()) -> RIO env ()
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. RIO env a -> IO a) -> IO ()) -> RIO env ())
-> ((forall a. RIO env a -> IO a) -> IO ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \forall a. RIO env a -> IO a
run -> WatchConfig -> (WatchManager -> IO ()) -> IO ()
forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
withManagerConf WatchConfig
cfg ((WatchManager -> IO ()) -> IO ())
-> (WatchManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WatchManager
manager -> do
    TVar (Set FilePath)
allFiles <- Set FilePath -> IO (TVar (Set FilePath))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Set FilePath
forall a. Set a
Set.empty
    TVar Bool
dirtyVar <- Bool -> IO (TVar Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Bool
True
    TVar (Map (Path Abs Dir) (IO ()))
watchVar <- Map (Path Abs Dir) (IO ())
-> IO (TVar (Map (Path Abs Dir) (IO ())))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Map (Path Abs Dir) (IO ())
forall k a. Map k a
Map.empty

    let onChange :: Event -> m ()
onChange Event
event = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            Set FilePath
files <- TVar (Set FilePath) -> STM (Set FilePath)
forall a. TVar a -> STM a
readTVar TVar (Set FilePath)
allFiles
            Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> FilePath
eventPath Event
event FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
files) (TVar Bool -> Bool -> STM ()
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
            STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Set FilePath) -> Set FilePath -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Set FilePath)
allFiles (Set FilePath -> STM ()) -> Set FilePath -> STM ()
forall a b. (a -> b) -> a -> b
$ (Path Abs File -> FilePath) -> Set (Path Abs File) -> Set FilePath
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Path Abs File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Set (Path Abs File)
files
            Map (Path Abs Dir) (IO ())
watch0 <- TVar (Map (Path Abs Dir) (IO ()))
-> IO (Map (Path Abs Dir) (IO ()))
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 = (Path Abs Dir -> IO () -> () -> Maybe (IO (Maybe (IO ()))))
-> (Map (Path Abs Dir) (IO ())
    -> Map (Path Abs Dir) (IO (Maybe (IO ()))))
-> (Map (Path Abs Dir) ()
    -> Map (Path Abs Dir) (IO (Maybe (IO ()))))
-> Map (Path Abs Dir) (IO ())
-> Map (Path Abs Dir) ()
-> Map (Path Abs Dir) (IO (Maybe (IO ())))
forall k a b c.
Ord k =>
(k -> a -> b -> Maybe c)
-> (Map k a -> Map k c)
-> (Map k b -> Map k c)
-> Map k a
-> Map k b
-> Map k c
Map.mergeWithKey
                    Path Abs Dir -> IO () -> () -> Maybe (IO (Maybe (IO ())))
forall (m :: * -> *) p a.
Monad m =>
p -> a -> () -> Maybe (m (Maybe a))
keepListening
                    Map (Path Abs Dir) (IO ())
-> Map (Path Abs Dir) (IO (Maybe (IO ())))
forall k a. Map k (IO ()) -> Map k (IO (Maybe a))
stopListening
                    Map (Path Abs Dir) () -> Map (Path Abs Dir) (IO (Maybe (IO ())))
forall b t.
Map (Path b t) () -> Map (Path b t) (IO (Maybe (IO ())))
startListening
                    Map (Path Abs Dir) (IO ())
watch0
                    Map (Path Abs Dir) ()
newDirs
            [Map (Path Abs Dir) (IO ())]
watch1 <- [(Path Abs Dir, IO (Maybe (IO ())))]
-> ((Path Abs Dir, IO (Maybe (IO ())))
    -> IO (Map (Path Abs Dir) (IO ())))
-> IO [Map (Path Abs Dir) (IO ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map (Path Abs Dir) (IO (Maybe (IO ())))
-> [(Path Abs Dir, IO (Maybe (IO ())))]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Path Abs Dir) (IO (Maybe (IO ())))
actions) (((Path Abs Dir, IO (Maybe (IO ())))
  -> IO (Map (Path Abs Dir) (IO ())))
 -> IO [Map (Path Abs Dir) (IO ())])
-> ((Path Abs Dir, IO (Maybe (IO ())))
    -> IO (Map (Path Abs Dir) (IO ())))
-> IO [Map (Path Abs Dir) (IO ())]
forall a b. (a -> b) -> a -> b
$ \(Path Abs Dir
k, IO (Maybe (IO ()))
mmv) -> do
                Maybe (IO ())
mv <- IO (Maybe (IO ()))
mmv
                Map (Path Abs Dir) (IO ()) -> IO (Map (Path Abs Dir) (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map (Path Abs Dir) (IO ()) -> IO (Map (Path Abs Dir) (IO ())))
-> Map (Path Abs Dir) (IO ()) -> IO (Map (Path Abs Dir) (IO ()))
forall a b. (a -> b) -> a -> b
$
                    case Maybe (IO ())
mv of
                        Maybe (IO ())
Nothing -> Map (Path Abs Dir) (IO ())
forall k a. Map k a
Map.empty
                        Just IO ()
v -> Path Abs Dir -> IO () -> Map (Path Abs Dir) (IO ())
forall k a. k -> a -> Map k a
Map.singleton Path Abs Dir
k IO ()
v
            STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Map (Path Abs Dir) (IO ()))
-> Map (Path Abs Dir) (IO ()) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Map (Path Abs Dir) (IO ()))
watchVar (Map (Path Abs Dir) (IO ()) -> STM ())
-> Map (Path Abs Dir) (IO ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ [Map (Path Abs Dir) (IO ())] -> Map (Path Abs Dir) (IO ())
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 = [(Path Abs Dir, ())] -> Map (Path Abs Dir) ()
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Path Abs Dir, ())] -> Map (Path Abs Dir) ())
-> [(Path Abs Dir, ())] -> Map (Path Abs Dir) ()
forall a b. (a -> b) -> a -> b
$ (Path Abs Dir -> (Path Abs Dir, ()))
-> [Path Abs Dir] -> [(Path Abs Dir, ())]
forall a b. (a -> b) -> [a] -> [b]
map (, ())
                    ([Path Abs Dir] -> [(Path Abs Dir, ())])
-> [Path Abs Dir] -> [(Path Abs Dir, ())]
forall a b. (a -> b) -> a -> b
$ Set (Path Abs Dir) -> [Path Abs Dir]
forall a. Set a -> [a]
Set.toList
                    (Set (Path Abs Dir) -> [Path Abs Dir])
-> Set (Path Abs Dir) -> [Path Abs Dir]
forall a b. (a -> b) -> a -> b
$ (Path Abs File -> Path Abs Dir)
-> Set (Path Abs File) -> Set (Path Abs Dir)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Set (Path Abs File)
files

            keepListening :: p -> a -> () -> Maybe (m (Maybe a))
keepListening p
_dir a
listen () = m (Maybe a) -> Maybe (m (Maybe a))
forall a. a -> Maybe a
Just (m (Maybe a) -> Maybe (m (Maybe a)))
-> m (Maybe a) -> Maybe (m (Maybe a))
forall a b. (a -> b) -> a -> b
$ Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
listen
            stopListening :: Map k (IO ()) -> Map k (IO (Maybe a))
stopListening = (IO () -> IO (Maybe a)) -> Map k (IO ()) -> Map k (IO (Maybe a))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((IO () -> IO (Maybe a)) -> Map k (IO ()) -> Map k (IO (Maybe a)))
-> (IO () -> IO (Maybe a)) -> Map k (IO ()) -> Map k (IO (Maybe a))
forall a b. (a -> b) -> a -> b
$ \IO ()
f -> do
                () <- IO ()
f IO () -> (IOException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \IOException
ioe ->
                    -- Ignore invalid argument error - it can happen if
                    -- the directory is removed.
                    case IOException -> IOErrorType
ioe_type IOException
ioe of
                        IOErrorType
InvalidArgument -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        IOErrorType
_ -> IOException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOException
ioe
                Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
            startListening :: Map (Path b t) () -> Map (Path b t) (IO (Maybe (IO ())))
startListening = (Path b t -> () -> IO (Maybe (IO ())))
-> Map (Path b t) () -> Map (Path b t) (IO (Maybe (IO ())))
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey ((Path b t -> () -> IO (Maybe (IO ())))
 -> Map (Path b t) () -> Map (Path b t) (IO (Maybe (IO ()))))
-> (Path b t -> () -> IO (Maybe (IO ())))
-> Map (Path b t) ()
-> Map (Path b t) (IO (Maybe (IO ())))
forall a b. (a -> b) -> a -> b
$ \Path b t
dir () -> do
                let dir' :: FilePath
dir' = FilePath -> FilePath
forall a. IsString a => FilePath -> a
fromString (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Path b t -> FilePath
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' (Bool -> ActionPredicate
forall a b. a -> b -> a
const Bool
True) Action
forall (m :: * -> *). MonadIO m => Event -> m ()
onChange
                Maybe (IO ()) -> IO (Maybe (IO ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (IO ()) -> IO (Maybe (IO ())))
-> Maybe (IO ()) -> IO (Maybe (IO ()))
forall a b. (a -> b) -> a -> b
$ IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just IO ()
listen

    let watchInput :: IO ()
watchInput = do
            FilePath
line <- IO FilePath
getLine
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath
line FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"quit") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                RIO env () -> IO ()
forall a. RIO env a -> IO a
run (RIO env () -> IO ()) -> RIO env () -> IO ()
forall a b. (a -> b) -> a -> b
$ case FilePath
line of
                    FilePath
"help" -> do
                        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
                        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"help: display this help"
                        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"quit: exit"
                        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"build: force a rebuild"
                        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"watched: display watched files"
                    FilePath
"build" -> STM () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> RIO env ()) -> STM () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
dirtyVar Bool
True
                    FilePath
"watched" -> do
                        Set FilePath
watch <- TVar (Set FilePath) -> RIO env (Set FilePath)
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar (Set FilePath)
allFiles
                        (FilePath -> RIO env ()) -> [FilePath] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ())
-> (FilePath -> Utf8Builder) -> FilePath -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString) (Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList Set FilePath
watch)
                    FilePath
"" -> STM () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> RIO env ()) -> STM () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
dirtyVar Bool
True
                    FilePath
_ -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
                        Utf8Builder
"Unknown command: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                        FilePath -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow FilePath
line Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                        Utf8Builder
". Try 'help'"

                IO ()
watchInput

    IO () -> IO Any -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m ()
race_ IO ()
watchInput (IO Any -> IO ()) -> IO Any -> IO ()
forall a b. (a -> b) -> a -> b
$ RIO env Any -> IO Any
forall a. RIO env a -> IO a
run (RIO env Any -> IO Any) -> RIO env Any -> IO Any
forall a b. (a -> b) -> a -> b
$ RIO env () -> RIO env Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (RIO env () -> RIO env Any) -> RIO env () -> RIO env Any
forall a b. (a -> b) -> a -> b
$ do
        STM () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> RIO env ()) -> STM () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
            Bool
dirty <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
dirtyVar
            Bool -> STM ()
check Bool
dirty

        Either SomeException ()
eres <- RIO env () -> RIO env (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (RIO env () -> RIO env (Either SomeException ()))
-> RIO env () -> RIO env (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ (Set (Path Abs File) -> IO ()) -> RIO env ()
inner Set (Path Abs File) -> IO ()
setWatched

        -- Clear dirtiness flag after the build to avoid an infinite
        -- loop caused by the build itself triggering dirtiness. This
        -- could be viewed as a bug, since files changed during the
        -- build will not trigger an extra rebuild, but overall seems
        -- like better behavior. See
        -- https://github.com/commercialhaskell/stack/issues/822
        STM () -> RIO env ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> RIO env ()) -> STM () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
dirtyVar Bool
False

        StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
          case Either SomeException ()
eres of
            Left SomeException
e ->
                let theStyle :: Style
theStyle = case SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                        Just ExitCode
ExitSuccess -> Style
Good
                        Maybe ExitCode
_ -> Style
Error
                 in Style -> StyleDoc -> StyleDoc
style Style
theStyle (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$ FilePath -> StyleDoc
forall a. IsString a => FilePath -> a
fromString (FilePath -> StyleDoc) -> FilePath -> StyleDoc
forall a b. (a -> b) -> a -> b
$ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
            Either SomeException ()
_ -> Style -> StyleDoc -> StyleDoc
style Style
Good StyleDoc
"Success! Waiting for next file change."

        Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Type help for available commands. Press enter to force a rebuild."