pituicat/src/Affection/Render.hs

87 lines
2.1 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) = x
inRender r (TRender f) = f r
changeColor :: RGBA -> RenderT RenderM ()
changeColor (RGBA r g b a) = TRender $ \rend ->
SDL.rendererDrawColor rend SDL.$= V4
(fromIntegral r)
(fromIntegral g)
(fromIntegral b)
(fromIntegral a)
clear :: RenderT RenderM ()
clear = TRender $ \r -> SDL.clear r
present :: RenderT RenderM ()
present = TRender $ \r -> SDL.present r