frpball/src/Types.hs

92 lines
2.4 KiB
Haskell

{-# 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
import Control.Concurrent.STM.TMVar
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]
, frpWindow :: TMVar SDL.Window
, frpThread :: SDL.ThreadID
}
type ContextParams = (T.Text, SDL.WindowConfig)
type Window = SDL.Window
type WindowConfig = SDL.WindowConfig
instance ContextHandler FRPBallCtx where
data ContextHandlerParameters FRPBallCtx = FRPBallCtxConfig T.Text SDL.WindowConfig
type ContextWindow FRPBallCtx = SDL.Window
type WindowParameters FRPBallCtx = (T.Text, SDL.WindowConfig)
contextHandlerCreate (FRPBallCtxConfig ititle iwinconfig) = do
tid <- SDL.threadID
win <- atomically $ newEmptyTMVar
ctx <- newTVarIO []
return $ FRPBallCtx ctx win tid
contextHandlerDelete ctx =
return ()
createContext frpctx (Just (bits, config)) = do
win <- SDL.createWindow (fst config) (snd config)
atomically $ putTMVar (frpWindow frpctx) win
ctx <- SDL.glCreateContext win
atomically $ modifyTVar (frpContexts frpctx) (ctx :)
SDL.showWindow win
return win
createContext frpctx Nothing = do
ctx <- SDL.glCreateContext =<< atomically (readTMVar $ frpWindow frpctx)
atomically $ modifyTVar (frpContexts frpctx) (ctx :)
atomically (readTMVar $ frpWindow frpctx)
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
GPipe.contextDelete frpctx =<< (atomically $ readTMVar $ frpWindow frpctx)
SDL.glDeleteContext mmContext
type AttrInput = (B4 Float, B3 Float)
type RIStream = (Float, AttrInput)