module LogView.LogView where
import qualified Control.Concurrent as Concurrent
import qualified Control.Concurrent.STM as STM
import qualified Control.Concurrent.STM.TChan as TChan
import qualified Control.Exception as Exception
import qualified Control.Monad.State as State
import qualified Data.ByteString.Char8 as ByteString
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified System.Console.GetOpt as GetOpt
import qualified System.Directory as Directory
import qualified System.Environment
import qualified System.Exit
import qualified System.Posix as Posix
import qualified Util.Exceptions as Exceptions
import qualified Util.Fltk as Fltk
import qualified Util.FltkUtil as FltkUtil
import qualified Util.Log as Log
import qualified Util.Processes as Processes
import qualified Util.Seq as Seq
import qualified App.Path as Path
import qualified App.ReplProtocol as ReplProtocol
import qualified LogView.LogViewC as LogViewC
import qualified LogView.Process as Process
import qualified LogView.Tail as Tail
import Global
pid_file :: FilePath
pid_file :: [Char]
pid_file = [Char]
"log/logview.pid"
initial_filter :: Text
initial_filter :: Text
initial_filter = Text
"**"
initial_size :: (Int, Int)
initial_size :: (Int, Int)
initial_size = (Int
900, Int
300)
default_catch_patterns :: [Process.CatchPattern]
default_catch_patterns :: [CatchPattern]
default_catch_patterns = [CatchPattern
Process.global_status_pattern]
default_history :: Int
default_history :: Int
default_history = Int
1000
default_max_bytes :: Int
default_max_bytes :: Int
default_max_bytes = Int
default_history Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100
data Flag = Help | Seek (Maybe Integer) | Print | History Int | File FilePath
| Geometry FltkUtil.Geometry
deriving (Flag -> Flag -> Bool
(Flag -> Flag -> Bool) -> (Flag -> Flag -> Bool) -> Eq Flag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq, Int -> Flag -> ShowS
[Flag] -> ShowS
Flag -> [Char]
(Int -> Flag -> ShowS)
-> (Flag -> [Char]) -> ([Flag] -> ShowS) -> Show Flag
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Flag] -> ShowS
$cshowList :: [Flag] -> ShowS
show :: Flag -> [Char]
$cshow :: Flag -> [Char]
showsPrec :: Int -> Flag -> ShowS
$cshowsPrec :: Int -> Flag -> ShowS
Show)
options :: [GetOpt.OptDescr Flag]
options :: [OptDescr Flag]
options =
[ [Char] -> [[Char]] -> ArgDescr Flag -> [Char] -> OptDescr Flag
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"help"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
GetOpt.NoArg Flag
Help) [Char]
"display usage"
, [Char] -> [[Char]] -> ArgDescr Flag -> [Char] -> OptDescr Flag
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"seek"] ((Maybe [Char] -> Flag) -> [Char] -> ArgDescr Flag
forall a. (Maybe [Char] -> a) -> [Char] -> ArgDescr a
GetOpt.OptArg (Maybe Integer -> Flag
Seek (Maybe Integer -> Flag)
-> (Maybe [Char] -> Maybe Integer) -> Maybe [Char] -> Flag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Integer) -> Maybe [Char] -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Integer
forall a. Read a => [Char] -> a
read) [Char]
"lines") ([Char] -> OptDescr Flag) -> [Char] -> OptDescr Flag
forall a b. (a -> b) -> a -> b
$
[Char]
"if given no arg, scan the log file from the beginning, if given an"
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" arg, scan approximately that many lines from the end (assuming"
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" the average line is 200 bytes)"
, [Char] -> [[Char]] -> ArgDescr Flag -> [Char] -> OptDescr Flag
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"print"] (Flag -> ArgDescr Flag
forall a. a -> ArgDescr a
GetOpt.NoArg Flag
Print)
[Char]
"print formatted logs to stdout instead of bringing up the GUI"
, [Char] -> [[Char]] -> ArgDescr Flag -> [Char] -> OptDescr Flag
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"history"]
(([Char] -> Flag) -> [Char] -> ArgDescr Flag
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
GetOpt.ReqArg (Int -> Flag
History (Int -> Flag) -> ([Char] -> Int) -> [Char] -> Flag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Int
forall a. Read a => [Char] -> a
read) (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
default_history))
[Char]
"remember this many lines"
, [Char] -> [[Char]] -> ArgDescr Flag -> [Char] -> OptDescr Flag
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"file"] (([Char] -> Flag) -> [Char] -> ArgDescr Flag
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
GetOpt.ReqArg [Char] -> Flag
File [Char]
"seq.log")
[Char]
"read from this file"
, (Geometry -> Flag) -> OptDescr Flag
forall a. (Geometry -> a) -> OptDescr a
FltkUtil.option Geometry -> Flag
Geometry
]
type LogChan = TChan.TChan Log.Msg
main :: IO ()
main :: IO ()
main = do
[[Char]]
args <- IO [[Char]]
System.Environment.getArgs
([Flag]
flags, [[Char]]
args) <- case ArgOrder Flag
-> [OptDescr Flag] -> [[Char]] -> ([Flag], [[Char]], [[Char]])
forall a.
ArgOrder a -> [OptDescr a] -> [[Char]] -> ([a], [[Char]], [[Char]])
GetOpt.getOpt ArgOrder Flag
forall a. ArgOrder a
GetOpt.Permute [OptDescr Flag]
options [[Char]]
args of
([Flag]
flags, [[Char]]
args, []) -> ([Flag], [[Char]]) -> IO ([Flag], [[Char]])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Flag]
flags, [[Char]]
args)
([Flag]
_, [[Char]]
_, [[Char]]
errs) -> [Char] -> IO ([Flag], [[Char]])
forall {b}. [Char] -> IO b
usage ([Char] -> IO ([Flag], [[Char]]))
-> [Char] -> IO ([Flag], [[Char]])
forall a b. (a -> b) -> a -> b
$ [Char]
"flag errors:\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. Monoid a => a -> [a] -> a
Seq.join [Char]
", " [[Char]]
errs
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
args) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
forall {b}. [Char] -> IO b
usage ([Char]
"unparsed args: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
args)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag
Help Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) ([Char] -> IO ()
forall {b}. [Char] -> IO b
usage [Char]
"usage:")
IO (Maybe ProcessID) -> (ProcessID -> IO ()) -> IO ()
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM IO (Maybe ProcessID)
write_pid ((ProcessID -> IO ()) -> IO ()) -> (ProcessID -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ProcessID
pid -> do
[Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"logview already running with pid " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ProcessID -> [Char]
forall a. Show a => a -> [Char]
show ProcessID
pid
IO ()
forall a. IO a
System.Exit.exitSuccess
[Flag] -> IO ()
logview [Flag]
flags IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`Exception.finally` [Char] -> IO ()
Directory.removeFile [Char]
pid_file
where
usage :: [Char] -> IO b
usage [Char]
msg = do
[Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ERROR: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msg
[Char] -> IO ()
putStrLn [Char]
"usage: logview [ flags ]"
[Char] -> IO ()
putStr ([Char] -> [OptDescr Flag] -> [Char]
forall a. [Char] -> [OptDescr a] -> [Char]
GetOpt.usageInfo [Char]
"" [OptDescr Flag]
options)
IO b
forall a. IO a
System.Exit.exitFailure
logview :: [Flag] -> IO ()
logview :: [Flag] -> IO ()
logview [Flag]
flags = do
let seek :: Maybe Integer
seek = Maybe Integer -> Maybe (Maybe Integer) -> Maybe Integer
forall a. a -> Maybe a -> a
fromMaybe (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0) (Maybe (Maybe Integer) -> Maybe Integer)
-> Maybe (Maybe Integer) -> Maybe Integer
forall a b. (a -> b) -> a -> b
$ [Maybe Integer] -> Maybe (Maybe Integer)
forall a. [a] -> Maybe a
Seq.last [Maybe Integer
s | Seek Maybe Integer
s <- [Flag]
flags]
history :: Int
history = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
default_history (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Maybe Int
forall a. [a] -> Maybe a
Seq.last [Int
n | History Int
n <- [Flag]
flags]
[Char]
filename <- IO [Char] -> ([Char] -> IO [Char]) -> Maybe [Char] -> IO [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO [Char]
Tail.log_filename [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> IO [Char]) -> Maybe [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Maybe [Char]
forall a. [a] -> Maybe a
Seq.last [[Char]
n | File [Char]
n <- [Flag]
flags]
Handle
hdl <- [Char] -> Maybe Integer -> IO Handle
Tail.open [Char]
filename Maybe Integer
seek
TChan Msg
log_chan <- IO (TChan Msg)
forall a. IO (TChan a)
STM.newTChanIO
Maybe Channel
gui_chan <- if Flag
Print Flag -> [Flag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags then Maybe Channel -> IO (Maybe Channel)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Channel
forall a. Maybe a
Nothing
else Channel -> Maybe Channel
forall a. a -> Maybe a
Just (Channel -> Maybe Channel) -> IO Channel -> IO (Maybe Channel)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Channel
Fltk.new_channel
ThreadId
main_thread <- IO ThreadId
Concurrent.myThreadId
IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
Concurrent.forkFinally (TChan Msg -> Handle -> IO ()
forall {b}. TChan Msg -> Handle -> IO b
tail_loop TChan Msg
log_chan Handle
hdl) ((Either SomeException () -> IO ()) -> IO ThreadId)
-> (Either SomeException () -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \Either SomeException ()
result -> do
[Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"tail loop died: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (SomeException -> [Char])
-> (() -> [Char]) -> Either SomeException () -> [Char]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> [Char]
forall a. Show a => a -> [Char]
show ([Char] -> () -> [Char]
forall a b. a -> b -> a
const [Char]
"no exception")
(Either SomeException ()
result :: Either Exception.SomeException ())
IO () -> (Channel -> IO ()) -> Maybe Channel -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ThreadId -> IO ()
Concurrent.killThread ThreadId
main_thread) Channel -> IO ()
Fltk.quit Maybe Channel
gui_chan
case Maybe Channel
gui_chan of
Maybe Channel
Nothing -> TChan Msg -> IO ()
print_logs TChan Msg
log_chan
Just Channel
chan -> Maybe Geometry -> Channel -> TChan Msg -> [Char] -> Int -> IO ()
gui Maybe Geometry
geometry Channel
chan TChan Msg
log_chan [Char]
filename Int
history
where geometry :: Maybe Geometry
geometry = [Geometry] -> Maybe Geometry
forall a. [a] -> Maybe a
Seq.head [Geometry
g | Geometry Geometry
g <- [Flag]
flags]
where
tail_loop :: TChan Msg -> Handle -> IO b
tail_loop TChan Msg
log_chan Handle
hdl = do
(Msg
msg, Handle
hdl) <- Handle -> IO (Msg, Handle)
Tail.tail Handle
hdl
STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan Msg -> Msg -> STM ()
forall a. TChan a -> a -> STM ()
TChan.writeTChan TChan Msg
log_chan Msg
msg
TChan Msg -> Handle -> IO b
tail_loop TChan Msg
log_chan Handle
hdl
write_pid :: IO (Maybe Posix.ProcessID)
write_pid :: IO (Maybe ProcessID)
write_pid = do
Maybe ByteString
pid_str <- IO ByteString -> IO (Maybe ByteString)
forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent (IO ByteString -> IO (Maybe ByteString))
-> IO ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
ByteString.readFile [Char]
pid_file
Maybe ProcessID
existing <- case ByteString -> Maybe (Int, ByteString)
ByteString.readInt (ByteString -> Maybe (Int, ByteString))
-> Maybe ByteString -> Maybe (Int, ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString
pid_str of
Just (Int
pid_, ByteString
_) -> do
Maybe [Char]
maybe_cmd <- ProcessID -> IO (Maybe [Char])
Processes.commandName ProcessID
pid
Maybe ProcessID -> IO (Maybe ProcessID)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ProcessID -> IO (Maybe ProcessID))
-> Maybe ProcessID -> IO (Maybe ProcessID)
forall a b. (a -> b) -> a -> b
$ if Bool -> ([Char] -> Bool) -> Maybe [Char] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ([Char]
"logview" `List.isSuffixOf`) Maybe [Char]
maybe_cmd
then ProcessID -> Maybe ProcessID
forall a. a -> Maybe a
Just ProcessID
pid else Maybe ProcessID
forall a. Maybe a
Nothing
where pid :: ProcessID
pid = Int -> ProcessID
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pid_
Maybe (Int, ByteString)
_ -> Maybe ProcessID -> IO (Maybe ProcessID)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ProcessID
forall a. Maybe a
Nothing
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ProcessID
existing Maybe ProcessID -> Maybe ProcessID -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ProcessID
forall a. Maybe a
Nothing) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
ProcessID
pid <- IO ProcessID
Posix.getProcessID
[Char] -> ByteString -> IO ()
ByteString.writeFile [Char]
pid_file ([Char] -> ByteString
ByteString.pack (ProcessID -> [Char]
forall a. Show a => a -> [Char]
show ProcessID
pid) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")
Maybe ProcessID -> IO (Maybe ProcessID)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ProcessID
existing
gui :: Maybe FltkUtil.Geometry -> Fltk.Channel -> LogChan -> FilePath -> Int
-> IO ()
gui :: Maybe Geometry -> Channel -> TChan Msg -> [Char] -> Int -> IO ()
gui Maybe Geometry
geometry Channel
chan TChan Msg
log_chan [Char]
filename Int
history = do
[Char]
filename <- [Char] -> IO [Char]
Directory.canonicalizePath [Char]
filename
let (Int
x, Int
y, Int
w, Int
h) =
Int -> Int -> Int -> Int -> Maybe Geometry -> (Int, Int, Int, Int)
FltkUtil.xywh Int
20 Int
20 ((Int, Int) -> Int
forall a b. (a, b) -> a
fst (Int, Int)
initial_size) ((Int, Int) -> Int
forall a b. (a, b) -> b
snd (Int, Int)
initial_size) Maybe Geometry
geometry
Window
win <- Fltk Window -> IO Window
forall a. Fltk a -> IO a
Fltk.run_action (Fltk Window -> IO Window) -> Fltk Window -> IO Window
forall a b. (a -> b) -> a -> b
$
Int -> Int -> Int -> Int -> [Char] -> Int -> Fltk Window
LogViewC.create Int
x Int
y Int
w Int
h [Char]
filename Int
default_max_bytes
Fltk () -> IO ()
forall a. Fltk a -> IO a
Fltk.run_action (Fltk () -> IO ()) -> Fltk () -> IO ()
forall a b. (a -> b) -> a -> b
$ Window -> Text -> Fltk ()
LogViewC.set_filter Window
win Text
initial_filter
let state :: State
state = (Text -> State
Process.initial_state Text
initial_filter)
{ state_catch_patterns :: [CatchPattern]
Process.state_catch_patterns = [CatchPattern]
default_catch_patterns }
IO () -> IO ThreadId
Concurrent.forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Channel -> State -> Int -> TChan Msg -> Window -> IO ()
handle_msgs Channel
chan State
state Int
history TChan Msg
log_chan Window
win
Channel -> IO ()
Fltk.event_loop Channel
chan
print_logs :: LogChan -> IO ()
print_logs :: TChan Msg -> IO ()
print_logs TChan Msg
log_chan = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Text -> IO ()
Text.IO.putStrLn (Text -> IO ()) -> (Msg -> Text) -> Msg -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Text
Log.format_msg
(Msg -> IO ()) -> IO Msg -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM Msg -> IO Msg
forall a. STM a -> IO a
STM.atomically (TChan Msg -> STM Msg
forall a. TChan a -> STM a
TChan.readTChan TChan Msg
log_chan)
data Msg = NewLog Log.Msg | ClickedWord Text | FilterChanged Text
deriving (Int -> Msg -> ShowS
[Msg] -> ShowS
Msg -> [Char]
(Int -> Msg -> ShowS)
-> (Msg -> [Char]) -> ([Msg] -> ShowS) -> Show Msg
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Msg] -> ShowS
$cshowList :: [Msg] -> ShowS
show :: Msg -> [Char]
$cshow :: Msg -> [Char]
showsPrec :: Int -> Msg -> ShowS
$cshowsPrec :: Int -> Msg -> ShowS
Show)
handle_msgs :: Fltk.Channel -> Process.State -> Int -> LogChan
-> LogViewC.Window -> IO ()
handle_msgs :: Channel -> State -> Int -> TChan Msg -> Window -> IO ()
handle_msgs Channel
chan State
st Int
history TChan Msg
log_chan Window
win = do
Path.AppDir [Char]
app_dir_ <- IO AppDir
Path.get_app_dir
let app_dir :: Text
app_dir = [Char] -> Text
txt [Char]
app_dir_ Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
(StateT State IO () -> State -> IO ())
-> State -> StateT State IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT State IO () -> State -> IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT State
st (StateT State IO () -> IO ()) -> StateT State IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ StateT State IO () -> StateT State IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (StateT State IO () -> StateT State IO ())
-> StateT State IO () -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ do
Msg
ui_msg <- IO Msg -> StateT State IO Msg
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Msg -> StateT State IO Msg) -> IO Msg -> StateT State IO Msg
forall a b. (a -> b) -> a -> b
$ TChan Msg -> Window -> IO Msg
get_msg TChan Msg
log_chan Window
win
case Msg
ui_msg of
NewLog Msg
msg_ -> do
let msg :: Msg
msg = Text -> Msg -> Msg
strip_paths Text
app_dir Msg
msg_
(State -> State) -> StateT State IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (Int -> Msg -> State -> State
Process.add_msg Int
history Msg
msg)
Channel -> Window -> Msg -> StateT State IO ()
handle_new_msg Channel
chan Window
win Msg
msg
ClickedWord Text
word -> IO () -> StateT State IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT State IO ()) -> IO () -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
handle_clicked_word Text
word
FilterChanged Text
expr -> do
Channel -> Fltk () -> StateT State IO ()
forall (m :: * -> *). MonadIO m => Channel -> Fltk () -> m ()
send_action Channel
chan (Fltk () -> StateT State IO ()) -> Fltk () -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ Window -> Fltk ()
LogViewC.clear_logs Window
win
(State -> State) -> StateT State IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((State -> State) -> StateT State IO ())
-> (State -> State) -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ \State
st ->
State
st { state_filter :: Filter
Process.state_filter = Text -> Filter
Process.compile_filter Text
expr }
[Msg]
all_msgs <- (State -> [Msg]) -> StateT State IO [Msg]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets ([Msg] -> [Msg]
forall a. [a] -> [a]
reverse ([Msg] -> [Msg]) -> (State -> [Msg]) -> State -> [Msg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> [Msg]
Process.state_msgs)
(Msg -> StateT State IO ()) -> [Msg] -> StateT State IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Channel -> Window -> Msg -> StateT State IO ()
handle_new_msg Channel
chan Window
win) [Msg]
all_msgs
strip_paths :: Text -> Log.Msg -> Log.Msg
strip_paths :: Text -> Msg -> Msg
strip_paths Text
dir Msg
msg =
Msg
msg { msg_text :: Text
Log.msg_text = Text -> Text -> Text -> Text
Text.replace Text
dir Text
"" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Msg -> Text
Log.msg_text Msg
msg }
handle_new_msg :: Fltk.Channel -> LogViewC.Window -> Log.Msg
-> State.StateT Process.State IO ()
handle_new_msg :: Channel -> Window -> Msg -> StateT State IO ()
handle_new_msg Channel
chan Window
win Msg
msg = do
State
state <- StateT State IO State
forall s (m :: * -> *). MonadState s m => m s
State.get
let (Maybe StyledText
styled, State
new_state) = State -> Msg -> (Maybe StyledText, State)
Process.process_msg State
state Msg
msg
State -> StateT State IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put State
new_state
case Maybe StyledText
styled of
Just (Process.StyledText ByteString
txt ByteString
style) -> Channel -> Fltk () -> StateT State IO ()
forall (m :: * -> *). MonadIO m => Channel -> Fltk () -> m ()
send_action Channel
chan (Fltk () -> StateT State IO ()) -> Fltk () -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ do
Window -> ByteString -> ByteString -> Fltk ()
LogViewC.append_log Window
win ByteString
txt ByteString
style
Bool -> Fltk () -> Fltk ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Msg -> Priority
Log.msg_priority Msg
msg Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
>= Priority
Log.Warn) (Fltk () -> Fltk ()) -> Fltk () -> Fltk ()
forall a b. (a -> b) -> a -> b
$
Window -> Fltk ()
LogViewC.bring_to_front Window
win
Maybe StyledText
Nothing -> () -> StateT State IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
let new_status :: Status
new_status = State -> Status
Process.state_status State
new_state
Bool -> StateT State IO () -> StateT State IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (State -> Status
Process.state_status State
state Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
/= Status
new_status) (StateT State IO () -> StateT State IO ())
-> StateT State IO () -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ do
let (Process.StyledText ByteString
status ByteString
style) = Status -> StyledText
Process.render_status Status
new_status
Channel -> Fltk () -> StateT State IO ()
forall (m :: * -> *). MonadIO m => Channel -> Fltk () -> m ()
send_action Channel
chan (Fltk () -> StateT State IO ()) -> Fltk () -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ Window -> ByteString -> ByteString -> Fltk ()
LogViewC.set_status Window
win ByteString
status ByteString
style
(State -> State) -> StateT State IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((State -> State) -> StateT State IO ())
-> (State -> State) -> StateT State IO ()
forall a b. (a -> b) -> a -> b
$ \State
st -> State
st { state_status :: Status
Process.state_status = Status
new_status }
handle_clicked_word :: Text -> IO ()
handle_clicked_word :: Text -> IO ()
handle_clicked_word Text
word
| Text
"{" Text -> Text -> Bool
`Text.isPrefixOf` Text
word Bool -> Bool -> Bool
&& Text
"}" Text -> Text -> Bool
`Text.isSuffixOf` Text
word =
Text -> IO ()
send_to_seq (Int -> Text -> Text
Text.drop Int
1 (Int -> Text -> Text
Text.dropEnd Int
1 Text
word))
| Bool
otherwise = [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"logview: unknown clicked word: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
forall a. Show a => a -> [Char]
show Text
word
send_action :: State.MonadIO m => Fltk.Channel -> Fltk.Fltk () -> m ()
send_action :: forall (m :: * -> *). MonadIO m => Channel -> Fltk () -> m ()
send_action Channel
chan = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Fltk () -> IO ()) -> Fltk () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel -> Fltk () -> IO ()
Fltk.action Channel
chan
send_to_seq :: Text -> IO ()
send_to_seq :: Text -> IO ()
send_to_seq Text
cmd = do
Text
response <- Text -> IO Text
ReplProtocol.query_cmd_simple Text
cmd
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
Text.null Text
response) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Text -> IO ()
Text.IO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"response: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
response
get_msg :: LogChan -> LogViewC.Window -> IO Msg
get_msg :: TChan Msg -> Window -> IO Msg
get_msg TChan Msg
log_chan Window
win = STM Msg -> IO Msg
forall a. STM a -> IO a
STM.atomically (STM Msg -> IO Msg) -> STM Msg -> IO Msg
forall a b. (a -> b) -> a -> b
$
(Msg -> Msg) -> STM Msg -> STM Msg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Msg -> Msg
NewLog (TChan Msg -> STM Msg
forall a. TChan a -> STM a
STM.readTChan TChan Msg
log_chan)
STM Msg -> STM Msg -> STM Msg
forall a. STM a -> STM a -> STM a
`STM.orElse` (Msg MsgType -> Msg) -> STM (Msg MsgType) -> STM Msg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Msg MsgType -> Msg
parse_ui_msg (Window -> STM (Msg MsgType)
forall a. Window a -> STM (Msg a)
Fltk.read_msg Window
win)
parse_ui_msg :: Fltk.Msg LogViewC.MsgType -> Msg
parse_ui_msg :: Msg MsgType -> Msg
parse_ui_msg (Fltk.Msg MsgType
typ Text
s) = case MsgType
typ of
MsgType
LogViewC.Click -> Text -> Msg
ClickedWord Text
s
MsgType
LogViewC.Command -> Text -> Msg
FilterChanged Text
s
LogViewC.Unknown CInt
n -> [Char] -> Msg
forall a. HasCallStack => [Char] -> a
error ([Char] -> Msg) -> [Char] -> Msg
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown msg type: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ CInt -> [Char]
forall a. Show a => a -> [Char]
show CInt
n