{-# 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