frpball/src/Types.hs

92 lines
2.4 KiB
Haskell
Raw Permalink Normal View History

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)