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

-- | 'DeviceContext' is the abstract handle into a specific 2D context inside a browser.
-- Note that the JavaScript API concepts of
-- @<https://developer.mozilla.org/en-US/docs/Web/API/CanvasRenderingContext2D CanvasRenderingContext2D>@ and
-- @<https://developer.mozilla.org/en-US/docs/Web/API/HTMLCanvasElement HTMLCanvasElement>@
-- are conflated in @blank-canvas@. Therefore, there is no
-- @<https://developer.mozilla.org/en-US/docs/Web/API/HTMLCanvasElement/getContext getContext()>@ method;
-- rather, @getContext()@ is implied (when using 'send').
data DeviceContext = DeviceContext
        { DeviceContext -> Document
theComet             :: KC.Document     -- ^ The mechanisms for sending commands
        , DeviceContext -> EventQueue
eventQueue           :: EventQueue      -- ^ A single (typed) event queue
        , DeviceContext -> Int
ctx_width            :: !Int
        , DeviceContext -> Int
ctx_height           :: !Int
        , DeviceContext -> Double
ctx_devicePixelRatio :: !Double
        , DeviceContext -> TVar (Set Text)
localFiles           :: TVar (Set Text) -- ^ approved local files
        , DeviceContext -> Bool
weakRemoteMonad      :: Bool            -- ^ use a weak remote monad for debugging
        }

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' returns the device's pixel ratio as used. Typically, the
-- browser ignores @devicePixelRatio@ in the canvas, which can make fine details
-- and text look fuzzy. Using the query @?hd@ on the URL, @blank-canvas@ attempts
-- to use the native @devicePixelRatio@, and if successful, 'devicePixelRatio' will
-- return a number other than 1. You can think of 'devicePixelRatio' as the line
-- width to use to make lines look one pixel wide.
devicePixelRatio ::  DeviceContext -> Double
devicePixelRatio :: DeviceContext -> Double
devicePixelRatio = DeviceContext -> Double
ctx_devicePixelRatio

-- | Internal command to send a message to the canvas.
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 for any event. Blocks.
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' all the current events, returning them all to the user. Never blocks.
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)