-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{- | This is a standalone program to monitor the log file.

    It reads lines and streams them to the GUI, which displays them in
    a scrolling box.  Clickable text is surrounded by @{}@s and will be
    highlighted blue in the GUI.  When it's clicked, the GUI sends the tag
    back, much like an HTML href.  For example, stack traces are formatted as
    a REPL cmd that will highlight that location on the score.

    The top line is the status bar, which extracts and remembers bits of
    specially formatted log msgs.  This effectively functions as the app's
    global status bar, since otherwise it has no place for this kind of
    information.  The configuration is 'default_catch_patterns'.

    This also maintains a filter.  The filter is a little language that will
    filter out messages that don't match, documented by
    'Process.compile_filter'.

    In addition, there is a concept of 'Process.CatchPattern's.  These are
    regexes which are matched against msg text.  When one matches, the matched
    groups are kept in a status line.  That way, events reported in the log can
    be collected together.
-}
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


-- | I use this file to only start one logview at a time.
pid_file :: FilePath
pid_file :: [Char]
pid_file = [Char]
"log/logview.pid"

-- | Initial contents of the filter field.
initial_filter :: Text
initial_filter :: Text
initial_filter = Text
"**"

initial_size :: (Int, Int)
initial_size :: (Int, Int)
initial_size = (Int
900, Int
300)

-- | Built-in list of catch patterns.
--
-- I wound up having the app emit catch patterns explicitly instead of putting
-- the smarts in logview, so now the only CatchPattern is
-- 'Process.global_status_pattern'.  But it still seems conceivable that
-- someday I may want logview to catch things the app didn't explicitly mean to
-- be caught, so I'll leave this functionality in for now.
default_catch_patterns :: [Process.CatchPattern]
default_catch_patterns :: [CatchPattern]
default_catch_patterns = [CatchPattern
Process.global_status_pattern]

-- | Remember this many log msgs.
default_history :: Int
default_history :: Int
default_history = Int
1000

-- | UI will remember this many bytes.  This is not the same as
-- 'default_history' because the history will remember filtered out msgs, and
-- the UI doesn't bother to preserve msg boundaries so it uses bytes.
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

-- | If a logview is already running, return its pid, otherwise write the
-- current pid.
write_pid :: IO (Maybe Posix.ProcessID)
write_pid :: IO (Maybe ProcessID)
write_pid = do
    -- I have to use ByteString.readFile and writeFile to avoid GHC's obnoxious
    -- file locking.
    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
                -- clear and redisplay msgs with new filter
                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

-- | Internally I use absolute paths, but they're pretty verbose.  So turn
-- them back into relative paths.
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
            -- This is an experimental feature to draw more attention when
            -- there's an interesting log msg.
            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