pituicat/src/Affection/Render.hs

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