86 lines
2.2 KiB
Haskell
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
|