From 89fc700dfed2dd97a2c1ebe0809fb7fcfffe0375 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 26 Mar 2016 03:50:39 +0100 Subject: [PATCH] wrapped into monad transformer --- affection.cabal | 14 ++++++-- src/Affection.hs | 8 ++--- src/Affection/Render.hs | 77 ++++++++++++++++++++++++++++++++++------- src/Affection/Types.hs | 26 ++++++++++---- 4 files changed, 98 insertions(+), 27 deletions(-) diff --git a/affection.cabal b/affection.cabal index 0e453c5..0c76ffc 100644 --- a/affection.cabal +++ b/affection.cabal @@ -26,19 +26,27 @@ cabal-version: >=1.10 library exposed-modules: Affection - extensions: OverloadedStrings - , GADTs + , Affection.Render + , 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 diff --git a/src/Affection.hs b/src/Affection.hs index 311d222..660e8f2 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -3,8 +3,8 @@ module Affection , withWindow , withDefaultWindow , delaySec - , Affection.Render - , Affection.Types + , module Affection.Render + , 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 () diff --git a/src/Affection/Render.hs b/src/Affection/Render.hs index fc05dab..3e4b12b 100644 --- a/src/Affection/Render.hs +++ b/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 SDL +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 :: (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 -inRender _ (Pure a) = return a -inRender r (Bind m f) = do - result <- inRender m r - inRender (f result) r -inRender r (Render f) = f r +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 -changeColor :: RGBA -> RenderM () -changeColor (RGBA r g b a) = Render $ \renderer -> rendererDrawColor renderer $= V4 r g b a +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 diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 5d34a89..0c350ef 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -1,13 +1,13 @@ module Affection.Types - ( newRGBA + ( RGBA + , newRGBA + , getR + , getG + , getB + , getA ) where -data RGBA = RGBA - { r :: Int - , g :: Int - , b :: Int - , a :: Int - } +data RGBA = RGBA Int Int Int 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