content: -- 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
  
  module Util.Fltk (
      Fltk, Result(..), fltk, action, quit, run_action, Channel, new_channel
      , event_loop
      -- * window
      , Window, win_ptr, MsgCallback, Msg(..)
      , create_window, read_msg
  ) where
  import qualified Control.Concurrent as Concurrent
  import qualified Control.Concurrent.STM as STM
  import qualified Control.Monad.Trans as Trans
  
  import qualified Data.ByteString as ByteString
  import qualified Data.Text as Text
  import qualified Data.Text.Encoding as Text.Encoding
  import qualified Data.Text.Encoding.Error as Encoding.Error
  
  import qualified Foreign
  import qualified Foreign.C as C
  
  
  newtype Fltk a = Fltk (IO a)
      deriving (Functor, Applicative, Monad, Trans.MonadIO)
  
  data Result = Continue | Quit
      deriving (Show)
  
  newtype Channel = Channel (Concurrent.MVar [Fltk Result])
  
  fltk :: IO a -> Fltk a
  fltk = Fltk
  
  -- | Send a Fltk action that doesn't quit.
  action :: Channel -> Fltk () -> IO ()
  action chan act = send_action chan (act >> return Continue)
  
  quit :: Channel -> IO ()
  quit chan = send_action chan (return Quit)
  
  -- | Run an action directly, rather than over the 'Channel'.  Only use this if
  -- you're certain you're the main thread!
  run_action :: Fltk a -> IO a
  run_action (Fltk act) = act
  
  new_channel :: IO Channel
  new_channel = Channel <$> Concurrent.newMVar []
  
  -- | Enter the fltk event loop.  For portability, this should only be called
  -- from the main thread.
  event_loop :: Channel -> IO ()
  event_loop chan = do
      c_initialize
      loop chan
      where
      loop chan = do
          done <- not . Foreign.toBool <$> c_has_windows
          if done then return () else do
              c_wait
              handle_actions chan >>= \case
                  Quit -> return ()
                  Continue -> loop chan
  
  handle_actions :: Channel -> IO Result
  handle_actions (Channel chan) = Concurrent.modifyMVar chan $ go . reverse
      -- The events are consed to the start, so reverse to get them back in
      -- the right order.
      where
      go (Fltk act : acts) = act >>= \case
          Quit -> return ([], Quit)
          Continue -> go acts
      go [] = return ([], Continue)
  
  send_action :: Channel -> Fltk Result -> IO ()
  send_action (Channel chan) act = do
      Concurrent.modifyMVar_ chan (return . (act:))
      c_awake
  
  foreign import ccall "initialize" c_initialize :: IO ()
  foreign import ccall "ui_wait" c_wait :: IO ()
  foreign import ccall "ui_awake" c_awake :: IO ()
  foreign import ccall "has_windows" c_has_windows :: IO C.CInt
  
  -- * window
  
  data Window a = Window {
      win_ptr :: Foreign.Ptr (Window a)
      , win_chan :: STM.TChan (Msg a)
      }
  type MsgCallback = C.CInt -> C.CString -> IO ()
  data Msg a = Msg a Text.Text
  
  type CreateWindow a = C.CInt -> C.CInt -> C.CInt -> C.CInt -> C.CString
      -> Foreign.FunPtr MsgCallback -> IO (Foreign.Ptr (Window a))
  
  create_window :: (C.CInt -> a) -> CreateWindow a -> Int -> Int -> Int -> Int
      -> String -> IO (Window a)
  create_window decode_type create_win x y w h title = do
      chan <- STM.newTChanIO
      cb <- c_make_msg_callback (cb_msg_callback decode_type chan)
      winp <- C.withCString title $ \titlep ->
          create_win (c x) (c y) (c w) (c h) titlep cb
      return (Window winp chan)
      where c = fromIntegral
  
  read_msg :: Window a -> STM.STM (Msg a)
  read_msg = STM.readTChan . win_chan
  
  
  -- * implementation
  
  cb_msg_callback :: (C.CInt -> a) -> STM.TChan (Msg a) -> MsgCallback
  cb_msg_callback decode_type msg_chan msg_type msgp = do
      msg <- peekCString msgp
      STM.atomically $ STM.writeTChan msg_chan (Msg (decode_type msg_type) msg)
  
  foreign import ccall "wrapper"
      c_make_msg_callback :: MsgCallback -> IO (Foreign.FunPtr MsgCallback)
  
  peekCString :: C.CString -> IO Text.Text
  peekCString cstr
      | cstr == Foreign.nullPtr = return Text.empty
      | otherwise = Text.Encoding.decodeUtf8With Encoding.Error.lenientDecode <$>
          ByteString.packCString cstr
  