{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Graphics.Blank.DeviceContext where
import Control.Concurrent.STM
import Data.Set (Set)
import Data.Text (Text)
import Graphics.Blank.Events
import Graphics.Blank.JavaScript
import Prelude.Compat
import TextShow (Builder, toText)
import qualified Web.Scotty.Comet as KC
data DeviceContext = DeviceContext
{ DeviceContext -> Document
theComet :: KC.Document
, DeviceContext -> EventQueue
eventQueue :: EventQueue
, DeviceContext -> Int
ctx_width :: !Int
, DeviceContext -> Int
ctx_height :: !Int
, DeviceContext -> Double
ctx_devicePixelRatio :: !Double
, DeviceContext -> TVar (Set Text)
localFiles :: TVar (Set Text)
, DeviceContext -> Bool
weakRemoteMonad :: Bool
}
instance Image DeviceContext where
jsImage :: DeviceContext -> Builder
jsImage = forall a. Image a => a -> Builder
jsImage forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeviceContext -> CanvasContext
deviceCanvasContext
width :: forall b. Num b => DeviceContext -> b
width = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeviceContext -> Int
ctx_width
height :: forall b. Num b => DeviceContext -> b
height = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeviceContext -> Int
ctx_height
deviceCanvasContext :: DeviceContext -> CanvasContext
deviceCanvasContext :: DeviceContext -> CanvasContext
deviceCanvasContext DeviceContext
cxt = Int -> Int -> Int -> CanvasContext
CanvasContext Int
0 (DeviceContext -> Int
ctx_width DeviceContext
cxt) (DeviceContext -> Int
ctx_height DeviceContext
cxt)
devicePixelRatio :: DeviceContext -> Double
devicePixelRatio :: DeviceContext -> Double
devicePixelRatio = DeviceContext -> Double
ctx_devicePixelRatio
sendToCanvas :: DeviceContext -> Builder -> IO ()
sendToCanvas :: DeviceContext -> Builder -> IO ()
sendToCanvas DeviceContext
cxt Builder
cmds = do
Document -> Text -> IO ()
KC.send (DeviceContext -> Document
theComet DeviceContext
cxt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toText forall a b. (a -> b) -> a -> b
$ Builder
"try{" forall a. Semigroup a => a -> a -> a
<> Builder
cmds forall a. Semigroup a => a -> a -> a
<> Builder
"}catch(e){alert('JavaScript Failure: '+e.message);}"
wait :: DeviceContext -> IO Event
wait :: DeviceContext -> IO Event
wait DeviceContext
c = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM a
readTChan (DeviceContext -> EventQueue
eventQueue DeviceContext
c)
flush :: DeviceContext -> IO [Event]
flush :: DeviceContext -> IO [Event]
flush DeviceContext
cxt = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ STM [Event]
loop
where loop :: STM [Event]
loop = do
Bool
b <- forall a. TChan a -> STM Bool
isEmptyTChan (DeviceContext -> EventQueue
eventQueue DeviceContext
cxt)
if Bool
b then forall (m :: * -> *) a. Monad m => a -> m a
return [] else do
Event
e <- forall a. TChan a -> STM a
readTChan (DeviceContext -> EventQueue
eventQueue DeviceContext
cxt)
[Event]
es <- STM [Event]
loop
forall (m :: * -> *) a. Monad m => a -> m a
return (Event
e forall a. a -> [a] -> [a]
: [Event]
es)