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

View file

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

View file

@ -1,35 +1,86 @@
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs, KindSignatures, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
module Affection.Render module Affection.Render
( RenderM ( RenderM
, inRender , inRender
, RenderT
, liftIO
, changeColor
, clear
, present
) where ) where
import Affection.Types (RGBA) import Affection.Types
import SDL import qualified SDL
import Linear (V4(..)) import Linear (V4(..))
import Control.Monad.Trans
data RenderM :: * -> * where data RenderM :: * -> * where
Pure :: a -> RenderM a Pure :: a -> RenderM a
Bind :: RenderM a -> (a -> RenderM b) -> RenderM b 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 instance Functor RenderM where
fmap f m = Bind m (Pure . f) fmap f m = Bind m (Pure . f)
instance Applicative RenderM where instance Applicative RenderM where
pure x = Pure x pure = Pure
mf <*> mx = Bind mf (\f -> Bind mx (\x -> Pure (f x))) mf <*> mx = Bind mf (\f -> Bind mx (\x -> Pure (f x)))
instance Monad RenderM where instance Monad RenderM where
m >>= f = Bind m f 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

View file

@ -1,13 +1,13 @@
module Affection.Types module Affection.Types
( newRGBA ( RGBA
, newRGBA
, getR
, getG
, getB
, getA
) where ) 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 :: Int -> Int -> Int -> Int -> RGBA
newRGBA r g b a = RGBA (overflow r) (overflow g) (overflow b) (overflow a) 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 overflow x
| x < 0 = 255 + (x `mod` 255) | x < 0 = 255 + (x `mod` 255)
| otherwise = 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