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

{-# LANGUAGE CPP #-}
-- | This has the FLTK event thread, and communication with it.
module Ui.Fltk (
    Fltk, fltk, Channel, event_loop, send_action, quit_ui_thread
) where
#ifdef STUB_OUT_FLTK
import Ui.FltkStub
#else

import qualified Control.Concurrent.MVar as MVar
import qualified Control.Concurrent.STM as STM
import qualified Control.Exception as Exception

import qualified Foreign
import qualified Foreign.C as C

import qualified Util.FFI as FFI
import qualified Util.Log as Log
import qualified Ui.UiMsg as UiMsg
import qualified Ui.UiMsgC as UiMsgC

import           Global


-- | See NOTE [ui-loop-timing]
action_timing :: Bool
action_timing :: Bool
action_timing = Bool
False

-- | You should only talk to FLTK from the main thread, which is also the FLTK
-- event thread.  So to call a FLTK function, you have to put it on
-- the UI 'Channel', where the FLTK thread will pick it up.  This also
-- serializes them, so I don't have to worry about concurrency at the Fltk
-- layer.  Since FLTK operations are wrapped in Fltk, and only this module can
-- unwrap a Fltk, this should enforce that you can't cell them willy-nilly.
newtype Fltk a = Fltk (IO a)
    deriving (Functor Fltk
forall a. a -> Fltk a
forall a b. Fltk a -> Fltk b -> Fltk a
forall a b. Fltk a -> Fltk b -> Fltk b
forall a b. Fltk (a -> b) -> Fltk a -> Fltk b
forall a b c. (a -> b -> c) -> Fltk a -> Fltk b -> Fltk c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Fltk a -> Fltk b -> Fltk a
$c<* :: forall a b. Fltk a -> Fltk b -> Fltk a
*> :: forall a b. Fltk a -> Fltk b -> Fltk b
$c*> :: forall a b. Fltk a -> Fltk b -> Fltk b
liftA2 :: forall a b c. (a -> b -> c) -> Fltk a -> Fltk b -> Fltk c
$cliftA2 :: forall a b c. (a -> b -> c) -> Fltk a -> Fltk b -> Fltk c
<*> :: forall a b. Fltk (a -> b) -> Fltk a -> Fltk b
$c<*> :: forall a b. Fltk (a -> b) -> Fltk a -> Fltk b
pure :: forall a. a -> Fltk a
$cpure :: forall a. a -> Fltk a
Applicative, forall a b. a -> Fltk b -> Fltk a
forall a b. (a -> b) -> Fltk a -> Fltk b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Fltk b -> Fltk a
$c<$ :: forall a b. a -> Fltk b -> Fltk a
fmap :: forall a b. (a -> b) -> Fltk a -> Fltk b
$cfmap :: forall a b. (a -> b) -> Fltk a -> Fltk b
Functor, Applicative Fltk
forall a. a -> Fltk a
forall a b. Fltk a -> Fltk b -> Fltk b
forall a b. Fltk a -> (a -> Fltk b) -> Fltk b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Fltk a
$creturn :: forall a. a -> Fltk a
>> :: forall a b. Fltk a -> Fltk b -> Fltk b
$c>> :: forall a b. Fltk a -> Fltk b -> Fltk b
>>= :: forall a b. Fltk a -> (a -> Fltk b) -> Fltk b
$c>>= :: forall a b. Fltk a -> (a -> Fltk b) -> Fltk b
Monad, Monad Fltk
forall a. IO a -> Fltk a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> Fltk a
$cliftIO :: forall a. IO a -> Fltk a
MonadIO)

fltk :: IO a -> Fltk a
fltk :: forall a. IO a -> Fltk a
fltk = forall a. IO a -> Fltk a
Fltk

-- | Channel to communicate with the FLTK event loop.  Yes it's not a real
-- channel, but I want to get all actions in one go, and an MVar is suitable
-- for that.
type Channel = MVar.MVar [(Fltk (), Text)]

-- | Putting something into this mvar signals the UI thread to quit.
type QuitRequest = MVar.MVar ()

-- | Run the FLTK event loop thread, passing it a channel that produces msgs,
-- and go into the UI polling loop.  This is intended to be run from the main
-- thread, since some UIs don't work properly unless run from the main thread.
-- When the app exits, the ui loop will be aborted.
event_loop :: Channel -> QuitRequest -> STM.TChan UiMsg.UiMsg -> IO ()
event_loop :: Channel -> QuitRequest -> TChan UiMsg -> IO ()
event_loop Channel
ui_chan QuitRequest
quit_request TChan UiMsg
msg_chan = do
    FunPtr (FunPtrFinalizer Any)
finalizer <- forall a. FunPtrFinalizer a -> IO (FunPtr (FunPtrFinalizer a))
c_make_free_fun_ptr forall a. FunPtr a -> IO ()
FFI.freeFunPtr
    forall a. FunPtr (FunPtrFinalizer a) -> IO ()
c_initialize FunPtr (FunPtrFinalizer Any)
finalizer
    forall (m :: * -> *) a. Monad m => m Bool -> m a -> m ()
while_ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (forall a. MVar a -> IO Bool
MVar.isEmptyMVar QuitRequest
quit_request)) forall a b. (a -> b) -> a -> b
$
        Channel -> TChan UiMsg -> IO ()
fltk_event_loop Channel
ui_chan TChan UiMsg
msg_chan

-- | When I do anything that will destroy previous callbacks, I have to pass
-- yet another callback which will be used to mark the old callbacks as done,
-- so that the haskell GC knows it can collect the data those callbacks use.
type FunPtrFinalizer a = Foreign.FunPtr a -> IO ()
foreign import ccall "wrapper"
    c_make_free_fun_ptr :: FunPtrFinalizer a
        -> IO (Foreign.FunPtr (FunPtrFinalizer a))

-- | Send the UI to the ui thread to run asynchronously.
send_action :: Channel -> Text -> Fltk () -> IO ()
send_action :: Channel -> Text -> Fltk () -> IO ()
send_action Channel
ui_chan Text
description Fltk ()
act = do
    forall a. MVar a -> (a -> IO a) -> IO ()
MVar.modifyMVar_ Channel
ui_chan forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Fltk ()
act, Text
description) :)
    IO ()
awake

{- NOTE [ui-loop-timing]
    Enable GUI timing by incrementing Timing::level in fltk/util.h.
    It will write to seq.events, then use tools/parse_timing.py to analyze it,
    or just look at it directly, to find where the big jumps are.

    util::timing emits timing events for the UI event loop, but it's confusing
    becasue things happen inside Fl::wait():

        Fl::wait() enter                [libfltk]
        "Block::draw"                   [c++]
        waiting for OS event            [OS] <-- blocking
        events collect in MsgCollector  [c++]
        "evt-xyz"
        Fl::wait() return
        "events"
        handle_actions (mutate fltk data via FFI)       [haskell]
        get UI msgs from MsgCollector, put on msg_chan  [haskell]
        "haskell"
        Fl::wait() enter

    So the single cycle goes "events", "haskell", "Block::draw".

    UI latency can come from:
    . handle_actions, if not already in normal form
    . Block::draw()

    Cmds run in their own async loop, which can also suffer from latency.  In
    that case, the UI is still responsive in theory, but not in practice since
    even selections go through cmd.
-}

-- | The FLTK event loop.
fltk_event_loop :: Channel -> STM.TChan UiMsg.UiMsg -> IO ()
fltk_event_loop :: Channel -> TChan UiMsg -> IO ()
fltk_event_loop Channel
ui_chan TChan UiMsg
msg_chan = do
    IO ()
wait
    -- I think that fltk will wake up once for every call to awake, so I
    -- shouldn't have to worry about another awake call coming in right
    -- here.
    Channel -> IO ()
handle_actions Channel
ui_chan
    [UiMsg]
ui_msgs <- IO [UiMsg]
UiMsgC.get_ui_msgs
    -- TODO
    -- when (length handled > 0 && length ui_msgs > 0)
    -- This means there is a possibility for a race.  If a haskell action says
    -- to e.g. set scroll to X and fltk says the scroll was set to Y, then
    -- haskell will record the scroll as Y while fltk has it as X.  I could
    -- mitigate this by cancelling out UiMsgs that are outdated by an incoming
    -- haskell action, but at the moment it doesn't seem worth the effort.
    --
    -- This is possible for UpdateTrackScroll and UpdateTimeScroll, but the
    -- effects should be fairly benign, and fixed as soon as there is any
    -- scrolling or zooming.  It would look like e.g. play from the top of
    -- the view playing from the wrong point.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UiMsg]
ui_msgs) forall a b. (a -> b) -> a -> b
$
        forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a. TChan a -> a -> STM ()
STM.writeTChan TChan UiMsg
msg_chan) [UiMsg]
ui_msgs

-- | Synchronously take actions out of the 'Channel' and run them.  This could
-- be asynchronous, but this way if the FLTK event loop wedges up then the UI
-- will also wedge up.  That's not exactly good, but it lets me know something
-- has gone wrong quickly.
handle_actions :: Channel -> IO ()
handle_actions :: Channel -> IO ()
handle_actions Channel
ui_chan = forall a. MVar a -> (a -> IO a) -> IO ()
MVar.modifyMVar_ Channel
ui_chan forall a b. (a -> b) -> a -> b
$ \[(Fltk (), Text)]
actions -> do
    -- Since actions are added to the front, reverse them before executing.
    forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle SomeException -> IO ()
handle forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. [a] -> [a]
reverse [(Fltk (), Text)]
actions) forall a b. (a -> b) -> a -> b
$ \(Fltk IO ()
action, Text
name) -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
action_timing forall a b. (a -> b) -> a -> b
$ forall a. Text -> (CString -> IO a) -> IO a
FFI.withText Text
name forall a b. (a -> b) -> a -> b
$ \CString
namep ->
                CInt -> CString -> IO ()
c_timing CInt
1 CString
namep
            IO ()
action
    forall (m :: * -> *) a. Monad m => a -> m a
return []
    where
    handle :: Exception.SomeException -> IO ()
    handle :: SomeException -> IO ()
handle SomeException
exc = forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ Text
"exception in event_loop: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt SomeException
exc

quit_ui_thread :: QuitRequest -> IO ()
quit_ui_thread :: QuitRequest -> IO ()
quit_ui_thread QuitRequest
quit_request = do
    forall a. MVar a -> IO (Maybe a)
MVar.tryTakeMVar QuitRequest
quit_request
    IO ()
awake -- get it out of wait

foreign import ccall "initialize"
    c_initialize :: Foreign.FunPtr (FunPtrFinalizer a) -> IO ()
foreign import ccall "ui_wait" wait :: IO ()
foreign import ccall "ui_awake" awake :: IO ()

foreign import ccall unsafe "timing" c_timing :: C.CInt -> C.CString -> IO ()

#endif