removed old module and added cleanup function
This commit is contained in:
parent
79cdc4934a
commit
6ed98fae2b
4 changed files with 32 additions and 115 deletions
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
|
|
@ -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.
|
||||||
|
|
Loading…
Reference in a new issue