{-# 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
#ifdef MIN_VERSION_Win32
import System.Win32.MinTTY (isMinTTYHandle)
import System.Win32.Types (withHandleToHANDLE)
#endif
import Text.Colour
#ifdef MIN_VERSION_safe_coloured_text_terminfo
import Text.Colour.Capabilities.FromEnv (getTerminalCapabilitiesFromEnv)
#else
import Text.Colour.Capabilities (TerminalCapabilities(..))
#endif
import UnliftIO

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 <- 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

  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

        forall a. WatchConfig -> (WatchManager -> IO a) -> IO a
FS.withManagerConf WatchConfig
FS.defaultConfig 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 <- 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
-> LoopSettings
-> TerminalCapabilities
-> ZonedTime
-> Chan Event
-> StopListening
worker ThreadId
mainThreadId LoopSettings
loopSettings TerminalCapabilities
terminalCapabilities ZonedTime
loopBegin Chan Event
eventChan
            forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` StopListening
stopListeningAction

  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 forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` TerminalCapabilities -> ZonedTime -> StopListening
putDone TerminalCapabilities
terminalCapabilities ZonedTime
loopBegin

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

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 {FilterSettings
OutputSettings
RunSettings
loopSettingOutputSettings :: LoopSettings -> OutputSettings
loopSettingFilterSettings :: LoopSettings -> FilterSettings
loopSettingRunSettings :: LoopSettings -> RunSettings
loopSettingOutputSettings :: OutputSettings
loopSettingFilterSettings :: FilterSettings
loopSettingRunSettings :: RunSettings
..} 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 forall a. Semigroup a => a -> a -> a
<>) 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
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. [Path b Dir] -> WalkAction b
WalkExclude forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Filter -> Path Abs File -> Bool
filterFileFilter Filter
f) forall a b. (a -> b) -> a -> b
$ 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 forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  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 (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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RestartEvent] -> ShowS
$cshowList :: [RestartEvent] -> ShowS
show :: RestartEvent -> String
$cshow :: RestartEvent -> String
showsPrec :: Int -> RestartEvent -> ShowS
$cshowsPrec :: Int -> RestartEvent -> ShowS
Show, RestartEvent -> RestartEvent -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RestartEvent -> RestartEvent -> Bool
$c/= :: RestartEvent -> RestartEvent -> Bool
== :: RestartEvent -> RestartEvent -> Bool
$c== :: RestartEvent -> RestartEvent -> Bool
Eq)

worker :: ThreadId -> LoopSettings -> TerminalCapabilities -> ZonedTime -> Chan FS.Event -> IO ()
worker :: ThreadId
-> LoopSettings
-> TerminalCapabilities
-> ZonedTime
-> Chan Event
-> StopListening
worker ThreadId
mainThreadId LoopSettings {FilterSettings
OutputSettings
RunSettings
loopSettingOutputSettings :: OutputSettings
loopSettingFilterSettings :: FilterSettings
loopSettingRunSettings :: RunSettings
loopSettingOutputSettings :: LoopSettings -> OutputSettings
loopSettingFilterSettings :: LoopSettings -> FilterSettings
loopSettingRunSettings :: LoopSettings -> RunSettings
..} 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 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

  -- 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 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 forall a b. (a -> b) -> a -> b
$ ExitCode -> Word64 -> Output
OutputProcessExited ExitCode
ec (Word64
end forall a. Num a => a -> a -> a
- Word64
start)

  -- 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 forall a b. (a -> b) -> a -> b
$ ExitCode -> Word64 -> Output
OutputProcessExited ExitCode
ec (Word64
end forall a. Num a => a -> a -> a
- Word64
start)
        -- Output the event that made the rerun happen
        RestartEvent
event <- Chan Event -> IO RestartEvent
waitForEvent Chan Event
eventChan
        Output -> StopListening
sendOutput 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 <-
    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 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.
        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 forall a. Maybe a
Nothing
  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 <- 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
      forall (m :: * -> *). MonadIO m => Handle -> BufferMode -> m ()
hSetBuffering Handle
stdin BufferMode
NoBuffering
      forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. a -> a
id
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race
          (Char -> RestartEvent
StdinEvent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Char
hGetChar Handle
stdin)
          (Event -> RestartEvent
FSEvent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => Chan a -> m a
readChan Chan Event
eventChan)
    else Event -> RestartEvent
FSEvent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Output] -> ShowS
$cshowList :: [Output] -> ShowS
show :: Output -> String
$cshow :: Output -> String
showsPrec :: Int -> Output -> ShowS
$cshowsPrec :: Int -> Output -> ShowS
Show)

putOutput :: OutputSettings -> TerminalCapabilities -> ZonedTime -> Output -> IO ()
putOutput :: OutputSettings
-> TerminalCapabilities -> ZonedTime -> Output -> StopListening
putOutput OutputSettings {Clear
outputSettingClear :: OutputSettings -> Clear
outputSettingClear :: 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 forall a b. (a -> b) -> a -> b
$
            String -> Chunk
indicatorChunk String
"event:" forall a. a -> [a] -> [a]
:
            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  ",
                  Text -> Chunk
chunk forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack 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 forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Chunk] -> StopListening
put forall a b. (a -> b) -> a -> b
$ RunSettings -> [[Chunk]]
startingLines RunSettings
runSettings
        OutputProcessExited ExitCode
ec Word64
nanosecs -> do
          [Chunk] -> StopListening
put forall a b. (a -> b) -> a -> b
$ ExitCode -> [Chunk]
exitCodeChunks ExitCode
ec
          [Chunk] -> StopListening
put forall a b. (a -> b) -> a -> b
$ Word64 -> [Chunk]
durationChunks Word64
nanosecs