{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Feedback.Loop where

import Control.Concurrent (ThreadId, myThreadId)
import Control.Exception (AsyncException (UserInterrupt))
import Control.Monad
import qualified Data.Text as T
import Data.Time
import Data.Word
import Feedback.Common.OptParse
import Feedback.Common.Output
import Feedback.Common.Process
import Feedback.Loop.Filter
import Feedback.Loop.OptParse
import GHC.Clock (getMonotonicTimeNSec)
import Path
import Path.IO
import System.Exit
import System.FSNotify as FS
import System.IO (hGetChar)
import System.Mem (performGC)
import System.Posix.Signals as Signal
import Text.Colour
import UnliftIO
#ifdef MIN_VERSION_Win32
import System.Win32.MinTTY (isMinTTYHandle)
import System.Win32.Types (withHandleToHANDLE)
#endif
#ifdef MIN_VERSION_safe_coloured_text_terminfo
import Text.Colour.Capabilities.FromEnv (getTerminalCapabilitiesFromEnv)
#else
import Text.Colour.Capabilities (TerminalCapabilities(..))
#endif

runFeedbackLoop :: IO ()
runFeedbackLoop :: StopListening
runFeedbackLoop = do
  -- The outer loop happens here, before 'getLoopSettings'
  -- so that the loop can be the thing that's being worked on as well.
  Path Abs Dir
here <- IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir

  -- We must get the stdin filter beforehand, because stdin can only be
  -- consumed once and we'll want to be able to reread filters below.
  Filter
stdinFilter <- Path Abs Dir -> IO Filter
mkStdinFilter Path Abs Dir
here

  -- Figure out if colours are supported up front, no need to do that in the
  -- loop.
  TerminalCapabilities
terminalCapabilities <- IO TerminalCapabilities
getTermCaps

  -- Get the threadid for a child process to throw an exception to when it's
  -- being killed by the user.
  ThreadId
mainThreadId <- IO ThreadId
myThreadId

  -- Get the flags and the environment up front, because they don't change
  -- anyway.
  -- This is also important because autocompletion won't work if we output
  -- something before parsing the flags.
  Flags
flags <- IO Flags
getFlags
  Environment
env <- IO Environment
getEnvironment

  -- Make sure the user knows what's happening.
  -- Note that this this must occur after the getFlags so that nothing is
  -- output before the autocompletion options can be activated.
  -- Otherwise the autocompletion output will fail to parse and autocomplete
  -- breaks.
  ZonedTime
firstBegin <- IO ZonedTime
getZonedTime
  TerminalCapabilities -> ZonedTime -> [Chunk] -> StopListening
putTimedChunks TerminalCapabilities
terminalCapabilities ZonedTime
firstBegin [String -> Chunk
indicatorChunk String
"preparing for first run"]

  -- Get the initial configuration so that we know if we need to run a hook after the first run.
  Maybe Configuration
mInitialConfiguration <- Flags -> Environment -> IO (Maybe Configuration)
getConfiguration Flags
flags Environment
env
  LoopSettings
initialSettings <- Flags -> Environment -> Maybe Configuration -> IO LoopSettings
combineToSettings Flags
flags Environment
env Maybe Configuration
mInitialConfiguration

  -- If a before-all hook is defined, run it now.
  Maybe RunSettings
-> (RunSettings -> StopListening) -> StopListening
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HooksSettings -> Maybe RunSettings
hooksSettingBeforeAll (LoopSettings -> HooksSettings
loopSettingHooksSettings LoopSettings
initialSettings)) ((RunSettings -> StopListening) -> StopListening)
-> (RunSettings -> StopListening) -> StopListening
forall a b. (a -> b) -> a -> b
$ \RunSettings
beforeAllRunSettings -> do
    TerminalCapabilities -> ZonedTime -> [Chunk] -> StopListening
putTimedChunks TerminalCapabilities
terminalCapabilities ZonedTime
firstBegin [String -> Chunk
indicatorChunk String
"starting before-all hook"]
    TerminalCapabilities -> ZonedTime -> RunSettings -> StopListening
runHook TerminalCapabilities
terminalCapabilities ZonedTime
firstBegin RunSettings
beforeAllRunSettings

  -- Define how to run a single loop with given settings in a let binding so we
  -- don't have to pass in args like 'here', 'stdinFilter' and
  -- 'terminalCapabilities'.
  let doSingleLoopWithSettings :: Bool -> ZonedTime -> LoopSettings -> StopListening
doSingleLoopWithSettings Bool
firstLoop ZonedTime
loopBegin LoopSettings
loopSettings = do
        WatchConfig -> (WatchManager -> StopListening) -> StopListening
forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
FS.withManagerConf WatchConfig
FS.defaultConfig ((WatchManager -> StopListening) -> StopListening)
-> (WatchManager -> StopListening) -> StopListening
forall a b. (a -> b) -> a -> b
$ \WatchManager
watchManager -> do
          -- Set up watchers for each relevant directory and send the FSNotify
          -- events down this event channel.
          Chan Event
eventChan <- IO (Chan Event)
forall (m :: * -> *) a. MonadIO m => m (Chan a)
newChan
          StopListening
stopListeningAction <-
            Path Abs Dir
-> Filter
-> TerminalCapabilities
-> ZonedTime
-> LoopSettings
-> WatchManager
-> Chan Event
-> IO StopListening
startWatching
              Path Abs Dir
here
              Filter
stdinFilter
              TerminalCapabilities
terminalCapabilities
              ZonedTime
loopBegin
              LoopSettings
loopSettings
              WatchManager
watchManager
              Chan Event
eventChan

          -- Start the process and put output.
          ThreadId
-> Bool
-> LoopSettings
-> TerminalCapabilities
-> ZonedTime
-> Chan Event
-> StopListening
worker ThreadId
mainThreadId Bool
firstLoop LoopSettings
loopSettings TerminalCapabilities
terminalCapabilities ZonedTime
loopBegin Chan Event
eventChan
            StopListening -> StopListening -> StopListening
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` StopListening
stopListeningAction

  -- Do the first loop outside the 'forever' so we can run commands before and
  -- after the first loop.
  Bool -> ZonedTime -> LoopSettings -> StopListening
doSingleLoopWithSettings Bool
True ZonedTime
firstBegin LoopSettings
initialSettings
    StopListening -> StopListening -> StopListening
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` TerminalCapabilities -> ZonedTime -> StopListening
putDone TerminalCapabilities
terminalCapabilities ZonedTime
firstBegin

  let doSingleLoop :: ZonedTime -> StopListening
doSingleLoop ZonedTime
loopBegin = do
        -- We show a 'preparing' chunk before we get the settings because sometimes
        -- getting the settings can take a while, for example in big repositories.
        TerminalCapabilities -> ZonedTime -> [Chunk] -> StopListening
putTimedChunks TerminalCapabilities
terminalCapabilities ZonedTime
loopBegin [String -> Chunk
indicatorChunk String
"preparing"]

        -- Get the loop configuration within the loop, so that the loop
        -- configuration can be what is being worked on.
        Maybe Configuration
mConfiguration <- Flags -> Environment -> IO (Maybe Configuration)
getConfiguration Flags
flags Environment
env
        LoopSettings
loopSettings <- Flags -> Environment -> Maybe Configuration -> IO LoopSettings
combineToSettings Flags
flags Environment
env Maybe Configuration
mConfiguration

        Bool -> ZonedTime -> LoopSettings -> StopListening
doSingleLoopWithSettings Bool
False ZonedTime
loopBegin LoopSettings
loopSettings

  let singleIteration :: StopListening
singleIteration = do
        -- Record when the loop began so we can show relative times nicely.
        ZonedTime
loopBegin <- IO ZonedTime
getZonedTime
        ZonedTime -> StopListening
doSingleLoop ZonedTime
loopBegin StopListening -> StopListening -> StopListening
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` TerminalCapabilities -> ZonedTime -> StopListening
putDone TerminalCapabilities
terminalCapabilities ZonedTime
loopBegin

  StopListening -> StopListening
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever StopListening
singleIteration

runHook :: TerminalCapabilities -> ZonedTime -> RunSettings -> IO ()
runHook :: TerminalCapabilities -> ZonedTime -> RunSettings -> StopListening
runHook TerminalCapabilities
terminalCapabilities ZonedTime
begin RunSettings
runSettings = do
  ([Chunk] -> StopListening) -> [[Chunk]] -> StopListening
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TerminalCapabilities -> ZonedTime -> [Chunk] -> StopListening
putTimedChunks TerminalCapabilities
terminalCapabilities ZonedTime
begin) (RunSettings -> [[Chunk]]
startingLines RunSettings
runSettings)
  ProcessHandle
_ <- RunSettings -> IO ProcessHandle
startProcessHandle RunSettings
runSettings
  -- We want this process to keep running, so we don't wait for it.
  () -> StopListening
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

startWatching ::
  Path Abs Dir ->
  Filter ->
  TerminalCapabilities ->
  ZonedTime ->
  LoopSettings ->
  WatchManager ->
  Chan FS.Event ->
  IO StopListening
startWatching :: Path Abs Dir
-> Filter
-> TerminalCapabilities
-> ZonedTime
-> LoopSettings
-> WatchManager
-> Chan Event
-> IO StopListening
startWatching Path Abs Dir
here Filter
stdinFilter TerminalCapabilities
terminalCapabilities ZonedTime
loopBegin LoopSettings {HooksSettings
OutputSettings
FilterSettings
RunSettings
loopSettingHooksSettings :: LoopSettings -> HooksSettings
loopSettingRunSettings :: RunSettings
loopSettingFilterSettings :: FilterSettings
loopSettingOutputSettings :: OutputSettings
loopSettingHooksSettings :: HooksSettings
loopSettingRunSettings :: LoopSettings -> RunSettings
loopSettingFilterSettings :: LoopSettings -> FilterSettings
loopSettingOutputSettings :: LoopSettings -> OutputSettings
..} WatchManager
watchManager Chan Event
eventChan = do
  let sendOutput :: Output -> IO ()
      sendOutput :: Output -> StopListening
sendOutput = OutputSettings
-> TerminalCapabilities -> ZonedTime -> Output -> StopListening
putOutput OutputSettings
loopSettingOutputSettings TerminalCapabilities
terminalCapabilities ZonedTime
loopBegin

  -- Build the filter that says which files and directories to care about
  Output -> StopListening
sendOutput Output
OutputFiltering
  Filter
f <- (Filter
stdinFilter Filter -> Filter -> Filter
forall a. Semigroup a => a -> a -> a
<>) (Filter -> Filter) -> IO Filter -> IO Filter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> FilterSettings -> IO Filter
mkCombinedFilter Path Abs Dir
here FilterSettings
loopSettingFilterSettings

  -- Set up the fsnotify watchers based on that filter
  Output -> StopListening
sendOutput Output
OutputWatching
  let descendHandler :: Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs)
      descendHandler :: Path Abs Dir
-> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs)
descendHandler Path Abs Dir
dir [Path Abs Dir]
subdirs [Path Abs File]
_ =
        -- Don't descent into hidden directories
        WalkAction Abs -> IO (WalkAction Abs)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalkAction Abs -> IO (WalkAction Abs))
-> WalkAction Abs -> IO (WalkAction Abs)
forall a b. (a -> b) -> a -> b
$ [Path Abs Dir] -> WalkAction Abs
forall b. [Path b Dir] -> WalkAction b
WalkExclude ([Path Abs Dir] -> WalkAction Abs)
-> [Path Abs Dir] -> WalkAction Abs
forall a b. (a -> b) -> a -> b
$ (Path Abs Dir -> Bool) -> [Path Abs Dir] -> [Path Abs Dir]
forall a. (a -> Bool) -> [a] -> [a]
filter (Path Abs Dir -> Path Abs Dir -> Bool
forall b t. Path b Dir -> Path b t -> Bool
isHiddenIn Path Abs Dir
dir) [Path Abs Dir]
subdirs
      outputWriter :: Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> IO StopListening
      outputWriter :: Path Abs Dir
-> [Path Abs Dir] -> [Path Abs File] -> IO StopListening
outputWriter Path Abs Dir
dir [Path Abs Dir]
_ [Path Abs File]
_ =
        if Filter -> Path Abs Dir -> Bool
filterDirFilter Filter
f Path Abs Dir
dir
          then do
            let eventFilter :: Event -> Bool
eventFilter Event
fsEvent = Bool -> (Path Abs File -> Bool) -> Maybe (Path Abs File) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Filter -> Path Abs File -> Bool
filterFileFilter Filter
f) (Maybe (Path Abs File) -> Bool) -> Maybe (Path Abs File) -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Maybe (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile (Event -> String
eventPath Event
fsEvent)
            WatchManager
-> String -> (Event -> Bool) -> Chan Event -> IO StopListening
watchDirChan WatchManager
watchManager (Path Abs Dir -> String
fromAbsDir Path Abs Dir
dir) Event -> Bool
eventFilter Chan Event
eventChan
          else StopListening -> IO StopListening
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> StopListening
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  Maybe
  (Path Abs Dir
   -> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs))
-> (Path Abs Dir
    -> [Path Abs Dir] -> [Path Abs File] -> IO StopListening)
-> Path Abs Dir
-> IO StopListening
forall (m :: * -> *) o b.
(MonadIO m, Monoid o) =>
Maybe
  (Path Abs Dir
   -> [Path Abs Dir] -> [Path Abs File] -> m (WalkAction Abs))
-> (Path Abs Dir -> [Path Abs Dir] -> [Path Abs File] -> m o)
-> Path b Dir
-> m o
walkDirAccum ((Path Abs Dir
 -> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs))
-> Maybe
     (Path Abs Dir
      -> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs))
forall a. a -> Maybe a
Just Path Abs Dir
-> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs)
descendHandler) Path Abs Dir
-> [Path Abs Dir] -> [Path Abs File] -> IO StopListening
outputWriter Path Abs Dir
here

#ifdef MIN_VERSION_safe_coloured_text_terminfo
getTermCaps :: IO TerminalCapabilities
getTermCaps :: IO TerminalCapabilities
getTermCaps = IO TerminalCapabilities
getTerminalCapabilitiesFromEnv
#else
getTermCaps :: IO TerminalCapabilities
getTermCaps = pure WithoutColours
#endif

data RestartEvent
  = FSEvent !FS.Event
  | StdinEvent !Char
  deriving (Int -> RestartEvent -> ShowS
[RestartEvent] -> ShowS
RestartEvent -> String
(Int -> RestartEvent -> ShowS)
-> (RestartEvent -> String)
-> ([RestartEvent] -> ShowS)
-> Show RestartEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RestartEvent -> ShowS
showsPrec :: Int -> RestartEvent -> ShowS
$cshow :: RestartEvent -> String
show :: RestartEvent -> String
$cshowList :: [RestartEvent] -> ShowS
showList :: [RestartEvent] -> ShowS
Show, RestartEvent -> RestartEvent -> Bool
(RestartEvent -> RestartEvent -> Bool)
-> (RestartEvent -> RestartEvent -> Bool) -> Eq RestartEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RestartEvent -> RestartEvent -> Bool
== :: RestartEvent -> RestartEvent -> Bool
$c/= :: RestartEvent -> RestartEvent -> Bool
/= :: RestartEvent -> RestartEvent -> Bool
Eq)

worker ::
  ThreadId ->
  Bool ->
  LoopSettings ->
  TerminalCapabilities ->
  ZonedTime ->
  Chan FS.Event ->
  IO ()
worker :: ThreadId
-> Bool
-> LoopSettings
-> TerminalCapabilities
-> ZonedTime
-> Chan Event
-> StopListening
worker
  ThreadId
mainThreadId
  Bool
thisIsTheFirstLoop
  LoopSettings {HooksSettings
OutputSettings
FilterSettings
RunSettings
loopSettingHooksSettings :: LoopSettings -> HooksSettings
loopSettingRunSettings :: LoopSettings -> RunSettings
loopSettingFilterSettings :: LoopSettings -> FilterSettings
loopSettingOutputSettings :: LoopSettings -> OutputSettings
loopSettingRunSettings :: RunSettings
loopSettingFilterSettings :: FilterSettings
loopSettingOutputSettings :: OutputSettings
loopSettingHooksSettings :: HooksSettings
..}
  TerminalCapabilities
terminalCapabilities
  ZonedTime
loopBegin
  Chan Event
eventChan = do
    let sendOutput :: Output -> IO ()
        sendOutput :: Output -> StopListening
sendOutput = OutputSettings
-> TerminalCapabilities -> ZonedTime -> Output -> StopListening
putOutput OutputSettings
loopSettingOutputSettings TerminalCapabilities
terminalCapabilities ZonedTime
loopBegin

    -- Record starting time of the process.
    -- This is different from 'loopBegin' because preparing the watchers may take
    -- a nontrivial amount of time.
    Word64
start <- IO Word64
getMonotonicTimeNSec

    -- Start the process process
    ProcessHandle
processHandle <- RunSettings -> IO ProcessHandle
startProcessHandle RunSettings
loopSettingRunSettings
    Output -> StopListening
sendOutput (Output -> StopListening) -> Output -> StopListening
forall a b. (a -> b) -> a -> b
$ RunSettings -> Output
OutputProcessStarted RunSettings
loopSettingRunSettings

    -- Perform GC after the process has started, because that's when we're
    -- waiting anyway, so that we don't need idle gc.
    StopListening
performGC

    -- Make sure we kill the process and wait for it to exit if a user presses
    -- C-c.
    ThreadId -> ProcessHandle -> StopListening
installKillHandler ThreadId
mainThreadId ProcessHandle
processHandle

    let runAfterFirstHookIfNecessary :: StopListening
runAfterFirstHookIfNecessary = do
          -- If this is the first run AND a after-first hook is defined, run it now.
          Bool -> StopListening -> StopListening
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
thisIsTheFirstLoop (StopListening -> StopListening) -> StopListening -> StopListening
forall a b. (a -> b) -> a -> b
$
            Maybe RunSettings
-> (RunSettings -> StopListening) -> StopListening
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HooksSettings -> Maybe RunSettings
hooksSettingAfterFirst HooksSettings
loopSettingHooksSettings) ((RunSettings -> StopListening) -> StopListening)
-> (RunSettings -> StopListening) -> StopListening
forall a b. (a -> b) -> a -> b
$ \RunSettings
afterFirstRunSettings -> do
              TerminalCapabilities -> ZonedTime -> [Chunk] -> StopListening
putTimedChunks TerminalCapabilities
terminalCapabilities ZonedTime
loopBegin [String -> Chunk
indicatorChunk String
"starting after-first hook"]
              TerminalCapabilities -> ZonedTime -> RunSettings -> StopListening
runHook TerminalCapabilities
terminalCapabilities ZonedTime
loopBegin RunSettings
afterFirstRunSettings
    -- From here on we will wait for either:
    -- 1. A change to a file that we are watching, or
    -- 2. The process to finish.

    -- 1. If An event happened first, output it and kill the process.
    let handleEventHappened :: RestartEvent -> StopListening
handleEventHappened RestartEvent
event = do
          -- Output the event that has fired
          Output -> StopListening
sendOutput (Output -> StopListening) -> Output -> StopListening
forall a b. (a -> b) -> a -> b
$ RestartEvent -> Output
OutputEvent RestartEvent
event
          -- Output that killing will start
          Output -> StopListening
sendOutput Output
OutputKilling
          -- Kill the process
          ProcessHandle -> StopListening
stopProcessHandle ProcessHandle
processHandle
          -- Output that the process has been killed
          Output -> StopListening
sendOutput Output
OutputKilled
          -- Wait for the process to finish (should have by now)
          ExitCode
ec <- ProcessHandle -> IO ExitCode
waitProcessHandle ProcessHandle
processHandle
          -- Record the end time
          Word64
end <- IO Word64
getMonotonicTimeNSec
          -- Output that the process has finished
          Output -> StopListening
sendOutput (Output -> StopListening) -> Output -> StopListening
forall a b. (a -> b) -> a -> b
$ ExitCode -> Word64 -> Output
OutputProcessExited ExitCode
ec (Word64
end Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
start)
          -- Process is done, run the after-first hook if necessary
          StopListening
runAfterFirstHookIfNecessary

    -- 2. If the process finished first, show the result and wait for an event anyway
    let handleProcessDone :: ExitCode -> StopListening
handleProcessDone ExitCode
ec = do
          Word64
end <- IO Word64
getMonotonicTimeNSec
          Output -> StopListening
sendOutput (Output -> StopListening) -> Output -> StopListening
forall a b. (a -> b) -> a -> b
$ ExitCode -> Word64 -> Output
OutputProcessExited ExitCode
ec (Word64
end Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
start)
          -- Process is done, run the after-first hook if necessary
          StopListening
runAfterFirstHookIfNecessary
          -- Output the event that made the rerun happen
          RestartEvent
event <- Chan Event -> IO RestartEvent
waitForEvent Chan Event
eventChan
          Output -> StopListening
sendOutput (Output -> StopListening) -> Output -> StopListening
forall a b. (a -> b) -> a -> b
$ RestartEvent -> Output
OutputEvent RestartEvent
event

    -- Either wait for it to finish or wait for an event
    Either RestartEvent ExitCode
eventOrDone <-
      IO RestartEvent -> IO ExitCode -> IO (Either RestartEvent ExitCode)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race
        (Chan Event -> IO RestartEvent
waitForEvent Chan Event
eventChan)
        (ProcessHandle -> IO ExitCode
waitProcessHandle ProcessHandle
processHandle)

    case Either RestartEvent ExitCode
eventOrDone of
      Left RestartEvent
event -> RestartEvent -> StopListening
handleEventHappened RestartEvent
event
      Right ExitCode
ec -> ExitCode -> StopListening
handleProcessDone ExitCode
ec

installKillHandler :: ThreadId -> ProcessHandle -> IO ()
installKillHandler :: ThreadId -> ProcessHandle -> StopListening
installKillHandler ThreadId
mainThreadId ProcessHandle
processHandle = do
  let killHandler :: Signal.Handler
      killHandler :: Handler
killHandler = StopListening -> Handler
CatchOnce (StopListening -> Handler) -> StopListening -> Handler
forall a b. (a -> b) -> a -> b
$ do
        ProcessHandle -> StopListening
stopProcessHandle ProcessHandle
processHandle
        ExitCode
_ <- ProcessHandle -> IO ExitCode
waitProcessHandle ProcessHandle
processHandle
        -- Throw a 'UserInterrupt' to the main thread so that the main thread
        -- can print done after the child processes have exited.
        ThreadId -> AsyncException -> StopListening
forall e (m :: * -> *).
(Exception e, MonadIO m) =>
ThreadId -> e -> m ()
throwTo ThreadId
mainThreadId AsyncException
UserInterrupt

  -- Install this kill handler for sigINT only.
  -- In the case of sigKILL, which we can't really be sure to catch anyway,
  -- crash harder.
  Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigINT Handler
killHandler Maybe SignalSet
forall a. Maybe a
Nothing
  () -> StopListening
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

waitForEvent :: Chan FS.Event -> IO RestartEvent
waitForEvent :: Chan Event -> IO RestartEvent
waitForEvent Chan Event
eventChan = do
  Bool
isTerminal <- Handle -> IO Bool
forall (m :: * -> *). MonadIO m => Handle -> m Bool
hIsTerminalDevice Handle
stdin
  Bool
isMinTTY <- IO Bool
getMinTTY
  if Bool
isTerminal Bool -> Bool -> Bool
|| Bool
isMinTTY
    then do
      Handle -> BufferMode -> StopListening
forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stdin BufferMode
NoBuffering
      (RestartEvent -> RestartEvent)
-> (RestartEvent -> RestartEvent)
-> Either RestartEvent RestartEvent
-> RestartEvent
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either RestartEvent -> RestartEvent
forall a. a -> a
id RestartEvent -> RestartEvent
forall a. a -> a
id
        (Either RestartEvent RestartEvent -> RestartEvent)
-> IO (Either RestartEvent RestartEvent) -> IO RestartEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO RestartEvent
-> IO RestartEvent -> IO (Either RestartEvent RestartEvent)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race
          (Char -> RestartEvent
StdinEvent (Char -> RestartEvent) -> IO Char -> IO RestartEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Char
hGetChar Handle
stdin)
          (Event -> RestartEvent
FSEvent (Event -> RestartEvent) -> IO Event -> IO RestartEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chan Event -> IO Event
forall (m :: * -> *) a. MonadIO m => Chan a -> m a
readChan Chan Event
eventChan)
    else Event -> RestartEvent
FSEvent (Event -> RestartEvent) -> IO Event -> IO RestartEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chan Event -> IO Event
forall (m :: * -> *) a. MonadIO m => Chan a -> m a
readChan Chan Event
eventChan

data Output
  = OutputFiltering
  | OutputWatching
  | OutputEvent !RestartEvent
  | OutputKilling
  | OutputKilled
  | OutputProcessStarted !RunSettings
  | OutputProcessExited !ExitCode !Word64
  deriving (Int -> Output -> ShowS
[Output] -> ShowS
Output -> String
(Int -> Output -> ShowS)
-> (Output -> String) -> ([Output] -> ShowS) -> Show Output
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Output -> ShowS
showsPrec :: Int -> Output -> ShowS
$cshow :: Output -> String
show :: Output -> String
$cshowList :: [Output] -> ShowS
showList :: [Output] -> ShowS
Show)

putOutput :: OutputSettings -> TerminalCapabilities -> ZonedTime -> Output -> IO ()
putOutput :: OutputSettings
-> TerminalCapabilities -> ZonedTime -> Output -> StopListening
putOutput OutputSettings {Clear
outputSettingClear :: Clear
outputSettingClear :: OutputSettings -> Clear
..} TerminalCapabilities
terminalCapabilities ZonedTime
loopBegin =
  let put :: [Chunk] -> StopListening
put = TerminalCapabilities -> ZonedTime -> [Chunk] -> StopListening
putTimedChunks TerminalCapabilities
terminalCapabilities ZonedTime
loopBegin
   in \case
        Output
OutputFiltering -> [Chunk] -> StopListening
put [String -> Chunk
indicatorChunk String
"filtering"]
        Output
OutputWatching -> [Chunk] -> StopListening
put [String -> Chunk
indicatorChunk String
"watching"]
        OutputEvent RestartEvent
restartEvent -> do
          [Chunk] -> StopListening
put ([Chunk] -> StopListening) -> [Chunk] -> StopListening
forall a b. (a -> b) -> a -> b
$
            String -> Chunk
indicatorChunk String
"event:"
              Chunk -> [Chunk] -> [Chunk]
forall a. a -> [a] -> [a]
: Chunk
" "
              Chunk -> [Chunk] -> [Chunk]
forall a. a -> [a] -> [a]
: case RestartEvent
restartEvent of
                FSEvent Event
fsEvent ->
                  [ case Event
fsEvent of
                      Added {} -> Colour -> Chunk -> Chunk
fore Colour
green Chunk
" added    "
                      Modified {} -> Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
" modified "
                      Removed {} -> Colour -> Chunk -> Chunk
fore Colour
red Chunk
" removed  "
                      Unknown {} -> Chunk
" unknown  "
                      ModifiedAttributes {} -> Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
" modified "
                      WatchedDirectoryRemoved {} -> Colour -> Chunk -> Chunk
fore Colour
red Chunk
" removed "
                      CloseWrite {} -> Colour -> Chunk -> Chunk
fore Colour
yellow Chunk
" modified ",
                    Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Event -> String
eventPath Event
fsEvent
                  ]
                StdinEvent Char
c -> [Colour -> Chunk -> Chunk
fore Colour
magenta Chunk
"manual restart: ", Text -> Chunk
chunk (Text -> Chunk) -> Text -> Chunk
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Char -> String
forall a. Show a => a -> String
show Char
c]
        Output
OutputKilling -> [Chunk] -> StopListening
put [String -> Chunk
indicatorChunk String
"killing"]
        Output
OutputKilled -> [Chunk] -> StopListening
put [String -> Chunk
indicatorChunk String
"killed"]
        OutputProcessStarted RunSettings
runSettings -> do
          case Clear
outputSettingClear of
            Clear
ClearScreen -> String -> StopListening
putStr String
"\ESCc"
            Clear
DoNotClearScreen -> () -> StopListening
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          ([Chunk] -> StopListening) -> [[Chunk]] -> StopListening
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Chunk] -> StopListening
put ([[Chunk]] -> StopListening) -> [[Chunk]] -> StopListening
forall a b. (a -> b) -> a -> b
$ RunSettings -> [[Chunk]]
startingLines RunSettings
runSettings
        OutputProcessExited ExitCode
ec Word64
nanosecs -> do
          [Chunk] -> StopListening
put ([Chunk] -> StopListening) -> [Chunk] -> StopListening
forall a b. (a -> b) -> a -> b
$ ExitCode -> [Chunk]
exitCodeChunks ExitCode
ec
          [Chunk] -> StopListening
put ([Chunk] -> StopListening) -> [Chunk] -> StopListening
forall a b. (a -> b) -> a -> b
$ Word64 -> [Chunk]
durationChunks Word64
nanosecs