-- 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 (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, 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, 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
Trans.MonadIO)

data Result = Continue | Quit
    deriving (Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show)

newtype Channel = Channel (Concurrent.MVar [Fltk Result])

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

-- | Send a Fltk action that doesn't quit.
action :: Channel -> Fltk () -> IO ()
action :: Channel -> Fltk () -> IO ()
action Channel
chan Fltk ()
act = Channel -> Fltk Result -> IO ()
send_action Channel
chan (Fltk ()
act forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Result
Continue)

quit :: Channel -> IO ()
quit :: Channel -> IO ()
quit Channel
chan = Channel -> Fltk Result -> IO ()
send_action Channel
chan (forall (m :: * -> *) a. Monad m => a -> m a
return Result
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 :: forall a. Fltk a -> IO a
run_action (Fltk IO a
act) = IO a
act

new_channel :: IO Channel
new_channel :: IO Channel
new_channel = MVar [Fltk Result] -> Channel
Channel forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
Concurrent.newMVar []

-- | Enter the fltk event loop.  For portability, this should only be called
-- from the main thread.
event_loop :: Channel -> IO ()
event_loop :: Channel -> IO ()
event_loop Channel
chan = do
    IO ()
c_initialize
    Channel -> IO ()
loop Channel
chan
    where
    loop :: Channel -> IO ()
loop Channel
chan = do
        Bool
done <- Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Num a) => a -> Bool
Foreign.toBool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO CInt
c_has_windows
        if Bool
done then forall (m :: * -> *) a. Monad m => a -> m a
return () else do
            IO ()
c_wait
            Channel -> IO Result
handle_actions Channel
chan forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Result
Quit -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Result
Continue -> Channel -> IO ()
loop Channel
chan

handle_actions :: Channel -> IO Result
handle_actions :: Channel -> IO Result
handle_actions (Channel MVar [Fltk Result]
chan) = forall a b. MVar a -> (a -> IO (a, b)) -> IO b
Concurrent.modifyMVar MVar [Fltk Result]
chan forall a b. (a -> b) -> a -> b
$ forall {a}. [Fltk Result] -> IO ([a], Result)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
    -- The events are consed to the start, so reverse to get them back in
    -- the right order.
    where
    go :: [Fltk Result] -> IO ([a], Result)
go (Fltk IO Result
act : [Fltk Result]
acts) = IO Result
act forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Result
Quit -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], Result
Quit)
        Result
Continue -> [Fltk Result] -> IO ([a], Result)
go [Fltk Result]
acts
    go [] = forall (m :: * -> *) a. Monad m => a -> m a
return ([], Result
Continue)

send_action :: Channel -> Fltk Result -> IO ()
send_action :: Channel -> Fltk Result -> IO ()
send_action (Channel MVar [Fltk Result]
chan) Fltk Result
act = do
    forall a. MVar a -> (a -> IO a) -> IO ()
Concurrent.modifyMVar_ MVar [Fltk Result]
chan (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fltk Result
act:))
    IO ()
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 {
    forall a. Window a -> Ptr (Window a)
win_ptr :: Foreign.Ptr (Window a)
    , forall a. Window a -> TChan (Msg 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 :: forall a.
(CInt -> a)
-> CreateWindow a
-> Int
-> Int
-> Int
-> Int
-> String
-> IO (Window a)
create_window CInt -> a
decode_type CreateWindow a
create_win Int
x Int
y Int
w Int
h String
title = do
    TChan (Msg a)
chan <- forall a. IO (TChan a)
STM.newTChanIO
    FunPtr MsgCallback
cb <- MsgCallback -> IO (FunPtr MsgCallback)
c_make_msg_callback (forall a. (CInt -> a) -> TChan (Msg a) -> MsgCallback
cb_msg_callback CInt -> a
decode_type TChan (Msg a)
chan)
    Ptr (Window a)
winp <- forall a. String -> (CString -> IO a) -> IO a
C.withCString String
title forall a b. (a -> b) -> a -> b
$ \CString
titlep ->
        CreateWindow a
create_win (Int -> CInt
c Int
x) (Int -> CInt
c Int
y) (Int -> CInt
c Int
w) (Int -> CInt
c Int
h) CString
titlep FunPtr MsgCallback
cb
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ptr (Window a) -> TChan (Msg a) -> Window a
Window Ptr (Window a)
winp TChan (Msg a)
chan)
    where c :: Int -> CInt
c = forall a b. (Integral a, Num b) => a -> b
fromIntegral

read_msg :: Window a -> STM.STM (Msg a)
read_msg :: forall a. Window a -> STM (Msg a)
read_msg = forall a. TChan a -> STM a
STM.readTChan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Window a -> TChan (Msg a)
win_chan


-- * implementation

cb_msg_callback :: (C.CInt -> a) -> STM.TChan (Msg a) -> MsgCallback
cb_msg_callback :: forall a. (CInt -> a) -> TChan (Msg a) -> MsgCallback
cb_msg_callback CInt -> a
decode_type TChan (Msg a)
msg_chan CInt
msg_type CString
msgp = do
    Text
msg <- CString -> IO Text
peekCString CString
msgp
    forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
STM.writeTChan TChan (Msg a)
msg_chan (forall a. a -> Text -> Msg a
Msg (CInt -> a
decode_type CInt
msg_type) Text
msg)

foreign import ccall "wrapper"
    c_make_msg_callback :: MsgCallback -> IO (Foreign.FunPtr MsgCallback)

peekCString :: C.CString -> IO Text.Text
peekCString :: CString -> IO Text
peekCString CString
cstr
    | CString
cstr forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
Foreign.nullPtr = forall (m :: * -> *) a. Monad m => a -> m a
return Text
Text.empty
    | Bool
otherwise = OnDecodeError -> ByteString -> Text
Text.Encoding.decodeUtf8With OnDecodeError
Encoding.Error.lenientDecode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        CString -> IO ByteString
ByteString.packCString CString
cstr