pituicat/src/Affection/Render.hs

87 lines
2.2 KiB
Haskell
Raw Normal View History

2016-03-26 02:50:39 +00:00
{-# LANGUAGE GADTs, KindSignatures, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
2016-03-25 15:58:46 +00:00
module Affection.Render
( RenderM
, inRender
2016-03-26 02:50:39 +00:00
, RenderT
, liftIO
, changeColor
, clear
, present
2016-03-25 15:58:46 +00:00
) where
2016-03-26 02:50:39 +00:00
import Affection.Types
import qualified SDL
2016-03-25 15:58:46 +00:00
import Linear (V4(..))
2016-03-26 02:50:39 +00:00
import Control.Monad.Trans
2016-03-25 15:58:46 +00:00
data RenderM :: * -> * where
Pure :: a -> RenderM a
Bind :: RenderM a -> (a -> RenderM b) -> RenderM b
2016-03-26 02:50:39 +00:00
Render :: (SDL.Renderer -> IO a) -> RenderM a
2016-03-25 15:58:46 +00:00
instance Functor RenderM where
fmap f m = Bind m (Pure . f)
instance Applicative RenderM where
2016-03-26 02:50:39 +00:00
pure = Pure
2016-03-25 15:58:46 +00:00
mf <*> mx = Bind mf (\f -> Bind mx (\x -> Pure (f x)))
instance Monad RenderM where
m >>= f = Bind m f
2016-03-26 02:50:39 +00:00
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
2016-03-25 15:58:46 +00:00
2016-03-26 02:50:39 +00:00
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