wrapped into monad transformer

This commit is contained in:
nek0 2016-03-26 03:50:39 +01:00
parent a457313ade
commit 89fc700dfe
4 changed files with 98 additions and 27 deletions

View File

@ -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

View File

@ -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 ()

View File

@ -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

View File

@ -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