wrapped into monad transformer

affection.cabal

@@ -26,19 +26,27 @@ cabal-version:       >=1.10
 
 library
   exposed-modules:     Affection
-  extensions: OverloadedStrings
+                     , Affection.Render
-            , GADTs
+                     , Affection.Types
+  default-extensions:  OverloadedStrings
+
   -- Modules included in this library but not exported.
   -- other-modules:       
   
   -- LANGUAGE extensions used by modules in this package.
-  -- other-extensions:    
+  other-extensions:    GADTs
+                     , KindSignatures
+                     , FlexibleInstances
+                     , MultiParamTypeClasses
+                     , UndecidableInstances
   hs-source-dirs:      src
   default-language:    Haskell2010
   -- Other library packages from which modules are imported.
   build-depends:       base >=4.8 && <4.9
                      , sdl2
                      , text
+                     , linear
+                     , mtl
                      -- , sdl2-image
 
 source-repository head

src/Affection.hs

@@ -3,8 +3,8 @@ module Affection
     , withWindow
     , withDefaultWindow
     , delaySec
-    , Affection.Render
+    , module Affection.Render
-    , Affection.Types
+    , module Affection.Types
     ) where
 
 import SDL
@@ -20,14 +20,14 @@ withAllAffection ops = do
   ops
   quit
 
-withWindow :: Text -> WindowConfig -> RendererConfig -> (Window -> Renderer -> IO ()) -> IO ()
+withWindow :: Monad m => Text -> WindowConfig -> RendererConfig -> RenderT m a -> IO ()
 withWindow title wconf rconf ops = do
   window <- createWindow title wconf
   renderer <- createRenderer window (-1) rconf
   inRender renderer $ ops
   destroyWindow window
 
-withDefaultWindow :: Text -> (Window -> Renderer -> IO ()) -> IO ()
+withDefaultWindow :: Monad m => Text -> (RenderT m a) -> IO ()
 withDefaultWindow title ops = withWindow title defaultWindow defaultRenderer ops
 
 delaySec :: Int -> IO ()

src/Affection/Render.hs

@@ -1,35 +1,86 @@
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GADTs, KindSignatures, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
 
 module Affection.Render
   ( RenderM
   , inRender
+  , RenderT
+  , liftIO
+  , changeColor
+  , clear
+  , present
   ) where
 
-import Affection.Types (RGBA)
+import Affection.Types
-import SDL
+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 :: (Renderer -> IO a) -> RenderM a
+  Render :: (SDL.Renderer -> IO a) -> RenderM a
 
 instance Functor RenderM where
   fmap f m = Bind m (Pure . f)
 
 instance Applicative RenderM where
-  pure x = Pure x
+  pure = Pure
   mf <*> mx = Bind mf (\f -> Bind mx (\x -> Pure (f x)))
 
 instance Monad RenderM where
   m >>= f = Bind m f
 
-inRender :: Renderer -> RenderM a -> IO a
+inRenderM :: SDL.Renderer -> RenderM a -> IO a
-inRender _ (Pure a) = return a
+inRenderM _ (Pure a) = return a
-inRender r (Bind m f) = do
+inRenderM r (Bind m f) = do
-  result <- inRender m r
+  result <- inRenderM r m
-  inRender (f result) r
+  inRenderM r (f result)
-inRender r (Render f) = f r
+inRenderM r (Render f) = f r
 
-changeColor :: RGBA -> RenderM ()
+data RenderT :: (* -> *) -> * -> * where
-changeColor (RGBA r g b a) = Render $ \renderer -> rendererDrawColor renderer $= V4 r g b a
+  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

src/Affection/Types.hs

@@ -1,13 +1,13 @@
 module Affection.Types
-  ( newRGBA
+  ( RGBA
+  , newRGBA
+  , getR
+  , getG
+  , getB
+  , getA
   ) where
 
-data RGBA = RGBA
+data RGBA = RGBA Int Int Int Int
-  { r :: Int
-  , g :: Int
-  , b :: Int
-  , a :: Int
-  }
 
 newRGBA :: Int -> Int -> Int -> Int -> RGBA
 newRGBA r g b a = RGBA (overflow r) (overflow g) (overflow b) (overflow a)
@@ -15,3 +15,15 @@ newRGBA r g b a = RGBA (overflow r) (overflow g) (overflow b) (overflow a)
     overflow x
       | x < 0     = 255 + (x `mod` 255)
       | otherwise = x `mod` 255
+
+getR :: RGBA -> Int
+getR (RGBA r _ _ _) = r
+
+getG :: RGBA -> Int
+getG (RGBA _ g _ _) = g
+
+getB :: RGBA -> Int
+getB (RGBA _ _ b _) = b
+
+getA :: RGBA -> Int
+getA (RGBA _ _ _ a) = a