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