removed old module and added cleanup function

This commit is contained in:
nek0 2016-11-13 13:39:25 +01:00
parent 79cdc4934a
commit 6ed98fae2b
4 changed files with 32 additions and 115 deletions

View file

@ -33,7 +33,7 @@ flag examples
library library
exposed-modules: Affection exposed-modules: Affection
, Affection.Render -- , Affection.Render
, Affection.Types , Affection.Types
default-extensions: OverloadedStrings default-extensions: OverloadedStrings

View file

@ -1,12 +1,11 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Affection module Affection
( withAffection ( withAffection
, withWindow -- , withWindow
, withDefaultWindow -- , withDefaultWindow
, delaySec , delaySec
, get , get
, put , put
, module Affection.Render
, module Types , module Types
) where ) where
@ -23,7 +22,6 @@ import Control.Monad.Loops
import Control.Monad.State import Control.Monad.State
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Affection.Render
import Affection.Types as Types import Affection.Types as Types
-- | Main function which bootstraps everything else. -- | Main function which bootstraps everything else.
@ -48,16 +46,16 @@ withAffection AffectionConfig{..} = do
, drawWindow = window , drawWindow = window
, drawSurface = surface , drawSurface = surface
}) =<< loadState surface }) =<< loadState surface
(_, _) <- runStateT ( Types.runState $ (_, nState) <- runStateT ( Types.runState $
whileM_ (do whileM_ (do
current <- get current <- get
return $ not $ Types.quitEvent current return $ not $ Types.quitEvent current
) )
(do (do
liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing
now <- liftIO $ getTime Monotonic now <- liftIO $ getTime Monotonic
lastTime <- liftIO $ fromMaybe now <$> tryReadMVar execTime lastTime <- liftIO $ fromMaybe now <$> tryReadMVar execTime
drawLoop drawLoop
liftIO $ SDL.surfaceBlit surface Nothing oldSurf Nothing
updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) /
(fromIntegral 10 ^ 9) (fromIntegral 10 ^ 9)
_ <- liftIO $ swapMVar execTime $ now _ <- liftIO $ swapMVar execTime $ now
@ -65,27 +63,28 @@ withAffection AffectionConfig{..} = do
) )
) initContainer ) initContainer
G.gegl_exit G.gegl_exit
cleanUp $ userState nState
SDL.quit SDL.quit
-- | DEPRECATED! -- -- | DEPRECATED!
-- Function for bootstraping a window. -- -- Function for bootstraping a window.
withWindow :: Monad m => T.Text -> WindowConfig -> SDL.RendererConfig -> RenderT m a -> IO () -- withWindow :: Monad m => T.Text -> WindowConfig -> SDL.RendererConfig -> RenderT m a -> IO ()
withWindow title wconf rconf ops = do -- withWindow title wconf rconf ops = do
window <- SDL.createWindow title wconf -- window <- SDL.createWindow title wconf
-- I don't need a renderer here, i need a surface -- -- I don't need a renderer here, i need a surface
renderer <- SDL.createRenderer window (-1) rconf -- renderer <- SDL.createRenderer window (-1) rconf
surface <- SDL.getWindowSurface window -- surface <- SDL.getWindowSurface window
G.gegl_init -- G.gegl_init
-- I think I need some AffectionT or someting similar here and not a RenderT -- -- I think I need some AffectionT or someting similar here and not a RenderT
-- from SDL. -- -- from SDL.
inRender renderer $ ops -- inRender renderer $ ops
G.gegl_exit -- G.gegl_exit
SDL.destroyWindow window -- SDL.destroyWindow window
--
-- | DEPRECATED! -- -- | DEPRECATED!
-- Bootstrap a default window. -- -- Bootstrap a default window.
withDefaultWindow :: Monad m => T.Text -> (RenderT m a) -> IO () -- withDefaultWindow :: Monad m => T.Text -> (RenderT m a) -> IO ()
withDefaultWindow title ops = withWindow title defaultWindow SDL.defaultRenderer ops -- withDefaultWindow title ops = withWindow title defaultWindow SDL.defaultRenderer ops
-- | block a thread for a specified amount of time -- | block a thread for a specified amount of time
delaySec delaySec

View file

@ -1,86 +0,0 @@
{-# 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) = x
inRender r (TRender f) = f r
changeColor :: RGBA -> RenderT RenderM ()
changeColor (RGBA r g b a) = TRender $ \rend ->
SDL.rendererDrawColor rend SDL.$= V4
(fromIntegral r)
(fromIntegral g)
(fromIntegral b)
(fromIntegral a)
clear :: RenderT RenderM ()
clear = TRender $ \r -> SDL.clear r
present :: RenderT RenderM ()
present = TRender $ \r -> SDL.present r

View file

@ -5,13 +5,15 @@ module Affection.Types
, AffectionState(..) , AffectionState(..)
-- , AffectionDraw(..) -- , AffectionDraw(..)
-- , Draw(..) -- , Draw(..)
, AffectionStateInner(..) , AffectionStateInner
-- , AffectionDrawInner(..) -- , AffectionDrawInner(..)
, InitComponents(..) , InitComponents(..)
-- , Loop(..) -- , Loop(..)
, RGBA(..) , RGBA(..)
, SDL.WindowConfig(..) , SDL.WindowConfig(..)
, SDL.defaultWindow , SDL.defaultWindow
-- | Convenience exports
, liftIO
) where ) where
import qualified SDL.Init as SDL import qualified SDL.Init as SDL
@ -20,9 +22,9 @@ import qualified Data.Text as T
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.State import Control.Monad.State
import Control.Monad.Reader -- import Control.Monad.Reader
import Control.Concurrent.MVar -- import Control.Concurrent.MVar
-- | Configuration for the aplication. needed at startup. -- | Configuration for the aplication. needed at startup.
data AffectionConfig us = AffectionConfig data AffectionConfig us = AffectionConfig
@ -38,6 +40,8 @@ data AffectionConfig us = AffectionConfig
-- ^ Main update function. Takes fractions of a second as input. -- ^ Main update function. Takes fractions of a second as input.
, loadState :: SDL.Surface -> IO us , loadState :: SDL.Surface -> IO us
-- ^ Provide your own load function to create this data. -- ^ Provide your own load function to create this data.
, cleanUp :: us -> IO ()
-- ^ Provide your own finisher function to clean your data.
} }
-- | Main type for defining the look, feel and action of the whole application. -- | Main type for defining the look, feel and action of the whole application.