86 lines
2.2 KiB
Haskell
86 lines
2.2 KiB
Haskell
{-# LANGUAGE GADTs, KindSignatures, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
|
|
|
|
module Affection.Render
|
|
( RenderM
|
|
, inRender
|
|
, RenderT
|
|
, liftIO
|
|
, changeColor
|
|
, clear
|
|
, present
|
|
) where
|
|
|
|
import Affection.Types
|
|
import qualified SDL
|
|
import Linear (V4(..))
|
|
import Control.Monad.Trans
|
|
|
|
data RenderM :: * -> * where
|
|
Pure :: a -> RenderM a
|
|
Bind :: RenderM a -> (a -> RenderM b) -> RenderM b
|
|
Render :: (SDL.Renderer -> IO a) -> RenderM a
|
|
|
|
instance Functor RenderM where
|
|
fmap f m = Bind m (Pure . f)
|
|
|
|
instance Applicative RenderM where
|
|
pure = Pure
|
|
mf <*> mx = Bind mf (\f -> Bind mx (\x -> Pure (f x)))
|
|
|
|
instance Monad RenderM where
|
|
m >>= f = Bind m f
|
|
|
|
inRenderM :: SDL.Renderer -> RenderM a -> IO a
|
|
inRenderM _ (Pure a) = return a
|
|
inRenderM r (Bind m f) = do
|
|
result <- inRenderM r m
|
|
inRenderM r (f result)
|
|
inRenderM r (Render f) = f r
|
|
|
|
data RenderT :: (* -> *) -> * -> * where
|
|
TPure :: a -> RenderT m a
|
|
TBind :: RenderT m a -> (a -> RenderT m b) -> RenderT m b
|
|
-- RunRenderT :: RenderT IO a -> IO a
|
|
TLift :: (Monad m) => m a -> RenderT m a
|
|
TLiftIO :: IO a -> RenderT m a
|
|
TRender :: (SDL.Renderer -> IO a) -> RenderT RenderM a
|
|
|
|
instance Functor (RenderT m) where
|
|
fmap f m = TBind m (TPure . f)
|
|
|
|
instance Applicative (RenderT m) where
|
|
pure = TPure
|
|
mf <*> mx = TBind mf (\f -> TBind mx (\x -> TPure (f x)))
|
|
|
|
instance Monad m => Monad (RenderT m) where
|
|
return = TPure
|
|
x >>= f = TBind x f
|
|
|
|
instance MonadTrans RenderT where
|
|
lift = TLift
|
|
|
|
instance Monad m => MonadIO (RenderT m) where
|
|
liftIO = TLiftIO
|
|
|
|
inRender :: Monad m => SDL.Renderer -> RenderT m a -> IO a
|
|
inRender _ (TPure a) = return a
|
|
inRender r (TBind m f) = do
|
|
result <- inRender r m
|
|
inRender r (f result)
|
|
-- inRender r (TLift x) = return x
|
|
inRender _ (TLiftIO x) = return =<< x
|
|
inRender r (TRender f) = f r
|
|
|
|
changeColor :: RGBA -> RenderT RenderM ()
|
|
changeColor colours = TRender $ \r ->
|
|
SDL.rendererDrawColor r SDL.$= V4
|
|
(fromIntegral $ getR colours)
|
|
(fromIntegral $ getG colours)
|
|
(fromIntegral $ getB colours)
|
|
(fromIntegral $ getA colours)
|
|
|
|
clear :: RenderT RenderM ()
|
|
clear = TRender $ \r -> SDL.clear r
|
|
|
|
present :: RenderT RenderM ()
|
|
present = TRender $ \r -> SDL.present r
|