{-# 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
Path Abs Dir
here <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
Filter
stdinFilter <- Path Abs Dir -> IO Filter
mkStdinFilter Path Abs Dir
here
TerminalCapabilities
terminalCapabilities <- IO TerminalCapabilities
getTermCaps
ThreadId
mainThreadId <- IO ThreadId
myThreadId
Flags
flags <- IO Flags
getFlags
Environment
env <- IO Environment
getEnvironment
let doSingleLoop :: ZonedTime -> StopListening
doSingleLoop ZonedTime
loopBegin = do
TerminalCapabilities -> ZonedTime -> [Chunk] -> StopListening
putTimedChunks TerminalCapabilities
terminalCapabilities ZonedTime
loopBegin [String -> Chunk
indicatorChunk String
"preparing"]
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
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
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
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
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
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]
_ =
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
Word64
start <- IO Word64
getMonotonicTimeNSec
ProcessHandle
processHandle <- RunSettings -> IO ProcessHandle
startProcessHandle RunSettings
loopSettingRunSettings
Output -> StopListening
sendOutput forall a b. (a -> b) -> a -> b
$ RunSettings -> Output
OutputProcessStarted RunSettings
loopSettingRunSettings
StopListening
performGC
ThreadId -> ProcessHandle -> StopListening
installKillHandler ThreadId
mainThreadId ProcessHandle
processHandle
let handleEventHappened :: RestartEvent -> StopListening
handleEventHappened RestartEvent
event = do
Output -> StopListening
sendOutput forall a b. (a -> b) -> a -> b
$ RestartEvent -> Output
OutputEvent RestartEvent
event
Output -> StopListening
sendOutput Output
OutputKilling
ProcessHandle -> StopListening
stopProcessHandle ProcessHandle
processHandle
Output -> StopListening
sendOutput Output
OutputKilled
ExitCode
ec <- ProcessHandle -> IO ExitCode
waitProcessHandle ProcessHandle
processHandle
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)
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)
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 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
forall e (m :: * -> *).
(Exception e, MonadIO m) =>
ThreadId -> e -> m ()
throwTo ThreadId
mainThreadId AsyncException
UserInterrupt
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