frpball/src/Types.hs
2019-08-04 11:25:06 +02:00

86 lines
2.2 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.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 :: Maybe 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
type ContextWindow FRPBallCtx = SDL.Window
type WindowParameters FRPBallCtx = (T.Text, SDL.WindowConfig)
contextHandlerCreate bla = do
tid <- SDL.threadID
win <- return Nothing
ctx <- newTVarIO []
return $ FRPBallCtx ctx win tid
contextHandlerDelete ctx =
return ()
createContext frpctx (Just (bits, config)) = do
win <- SDL.createWindow (fst config) (snd config)
ctx <- SDL.glCreateContext (fromJust $ frpWindow frpctx)
atomically $ modifyTVar (frpContexts frpctx) (ctx :)
SDL.showWindow win
return win
createContext frpctx Nothing = do
ctx <- SDL.glCreateContext (fromJust $ frpWindow frpctx)
atomically $ modifyTVar (frpContexts frpctx) (ctx :)
return $ fromJust $ 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 (fromJust $ frpWindow frpctx)
SDL.glDeleteContext mmContext