2019-08-04 09:25:06 +00:00
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
|
|
|
|
module Types where
|
|
|
|
|
|
|
|
import Linear (V2(..))
|
|
|
|
|
|
|
|
import qualified Data.Text as T
|
|
|
|
import Data.Maybe (fromJust)
|
|
|
|
|
|
|
|
import Control.Monad (forM_)
|
|
|
|
|
|
|
|
import Control.Concurrent.STM (atomically)
|
|
|
|
import Control.Concurrent.STM.TVar
|
2019-08-29 19:29:16 +00:00
|
|
|
import Control.Concurrent.STM.TMVar
|
2019-08-04 09:25:06 +00:00
|
|
|
|
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
|
|
|
|
import qualified SDL
|
|
|
|
import qualified SDL.Raw.Thread as SDL (threadID)
|
|
|
|
import qualified SDL.Raw.Types as SDL (ThreadID)
|
|
|
|
import Graphics.GL (glFinish)
|
|
|
|
|
|
|
|
import Graphics.GPipe as GPipe
|
|
|
|
|
|
|
|
import Foreign.C.Types (CInt(..))
|
|
|
|
|
|
|
|
data MouseEvent = MouseEvent
|
|
|
|
{ pos :: V2 Int
|
|
|
|
}
|
|
|
|
|
|
|
|
data FRPBallCtx = FRPBallCtx
|
|
|
|
{ frpContexts :: TVar [SDL.GLContext]
|
2019-08-29 19:29:16 +00:00
|
|
|
, frpWindow :: TMVar SDL.Window
|
2019-08-04 09:25:06 +00:00
|
|
|
, frpThread :: SDL.ThreadID
|
|
|
|
}
|
|
|
|
|
|
|
|
type ContextParams = (T.Text, SDL.WindowConfig)
|
|
|
|
|
|
|
|
type Window = SDL.Window
|
|
|
|
|
|
|
|
type WindowConfig = SDL.WindowConfig
|
|
|
|
|
|
|
|
instance ContextHandler FRPBallCtx where
|
2019-08-25 12:22:02 +00:00
|
|
|
data ContextHandlerParameters FRPBallCtx = FRPBallCtxConfig T.Text SDL.WindowConfig
|
2019-08-04 09:25:06 +00:00
|
|
|
type ContextWindow FRPBallCtx = SDL.Window
|
|
|
|
type WindowParameters FRPBallCtx = (T.Text, SDL.WindowConfig)
|
|
|
|
|
2019-08-25 12:22:02 +00:00
|
|
|
contextHandlerCreate (FRPBallCtxConfig ititle iwinconfig) = do
|
2019-08-04 09:25:06 +00:00
|
|
|
tid <- SDL.threadID
|
2019-08-29 19:29:16 +00:00
|
|
|
win <- atomically $ newEmptyTMVar
|
2019-08-04 09:25:06 +00:00
|
|
|
ctx <- newTVarIO []
|
|
|
|
return $ FRPBallCtx ctx win tid
|
|
|
|
|
|
|
|
contextHandlerDelete ctx =
|
|
|
|
return ()
|
|
|
|
|
|
|
|
createContext frpctx (Just (bits, config)) = do
|
|
|
|
win <- SDL.createWindow (fst config) (snd config)
|
2019-08-29 19:29:16 +00:00
|
|
|
atomically $ putTMVar (frpWindow frpctx) win
|
2019-08-25 12:22:02 +00:00
|
|
|
ctx <- SDL.glCreateContext win
|
2019-08-04 09:25:06 +00:00
|
|
|
atomically $ modifyTVar (frpContexts frpctx) (ctx :)
|
|
|
|
SDL.showWindow win
|
|
|
|
return win
|
|
|
|
|
|
|
|
createContext frpctx Nothing = do
|
2019-08-29 19:29:16 +00:00
|
|
|
ctx <- SDL.glCreateContext =<< atomically (readTMVar $ frpWindow frpctx)
|
2019-08-04 09:25:06 +00:00
|
|
|
atomically $ modifyTVar (frpContexts frpctx) (ctx :)
|
2019-08-29 19:29:16 +00:00
|
|
|
atomically (readTMVar $ frpWindow frpctx)
|
2019-08-04 09:25:06 +00:00
|
|
|
|
|
|
|
contextDoAsync ctx mwin act =
|
|
|
|
liftIO act
|
|
|
|
|
|
|
|
contextSwap ctx win =
|
|
|
|
SDL.glSwapWindow win
|
|
|
|
|
|
|
|
contextFrameBufferSize ctx win = do
|
|
|
|
(V2 w h) <- (\(V2 (CInt int1) (CInt int2) ) ->
|
|
|
|
V2 (fromIntegral int1) (fromIntegral int2))
|
|
|
|
<$> SDL.get (SDL.windowSize win)
|
|
|
|
return (w, h)
|
|
|
|
|
|
|
|
contextDelete frpctx win = do
|
|
|
|
glFinish
|
|
|
|
ctxs <- readTVarIO $ frpContexts frpctx
|
|
|
|
forM_ ctxs $ \mmContext -> do
|
2019-08-29 19:29:16 +00:00
|
|
|
GPipe.contextDelete frpctx =<< (atomically $ readTMVar $ frpWindow frpctx)
|
2019-08-04 09:25:06 +00:00
|
|
|
SDL.glDeleteContext mmContext
|
2019-08-25 12:22:02 +00:00
|
|
|
|
|
|
|
type AttrInput = (B4 Float, B3 Float)
|
|
|
|
|
|
|
|
type RIStream = (Float, AttrInput)
|