working types, but no working implementation

affection.cabal

@@ -55,6 +55,8 @@ library
                      , linear
                      , mtl
                      , gegl
+                     , monad-loops
+                     , timeit
                      -- , sdl2-image
 
 executable example00

src/Affection.hs

@@ -1,5 +1,6 @@
+{-# LANGUAGE RecordWildCards #-}
 module Affection
-    ( withAllAffection
+    ( withAffection
     , withWindow
     , withDefaultWindow
     , delaySec
@@ -7,34 +8,62 @@ module Affection
     , module Affection.Types
     ) where
 
-import SDL
+import qualified SDL
-import Data.Text
+import qualified GEGL as G
-import GEGL
+
+import qualified Data.Text as T
+import Data.Maybe
+
+import System.TimeIt (timeItT)
+
+import Control.Monad.Loops
+import Control.Monad.State
+import Control.Monad.Reader
+import Control.Concurrent.MVar
 
 import Affection.Render
-import Affection.Types
+import Affection.Types as Types
 
-withAllAffection :: IO () -> IO ()
+withAffection :: AffectionConfig us -> IO ()
-withAllAffection ops = do
+withAffection conf@AffectionConfig{..} = do
-  initializeAll
+  case initComponents of
-  ops
+    All ->
-  quit
+      SDL.initializeAll
+    Only is ->
+      SDL.initialize is
+  execTime <- newMVar 0
+  window <- SDL.createWindow windowTitle windowConfig
+  surface <- SDL.getWindowSurface window
+  let initContainer = AffectionData conf False userData window surface
+  state <- newMVar initContainer
+  (res, nState) <- runStateT (
+    whileM_ (do
+        current <- get
+        return $ Types.quitEvent current
+      )
+      $ do
+        lastTime <- liftIO $ fromMaybe 0 <$> tryReadMVar execTime
+        (dTime, _) <- liftIO $ timeItT <$> drawLoop
+        (uTime, _) <- liftIO $ timeItT <$> updateLoop lastTime
+        liftIO $ putMVar execTime $ lastTime + dTime + uTime
+    ) initContainer
+  SDL.quit
 
-withWindow :: Monad m => Text -> WindowConfig -> RendererConfig -> RenderT m a -> IO ()
+withWindow :: Monad m => T.Text -> WindowConfig -> SDL.RendererConfig -> RenderT m a -> IO ()
 withWindow title wconf rconf ops = do
-  window <- createWindow title wconf
+  window <- SDL.createWindow title wconf
   -- I don't need a renderer here, i need a surface
-  renderer <- createRenderer window (-1) rconf
+  renderer <- SDL.createRenderer window (-1) rconf
-  surface <- getWindowSurface window
+  surface <- SDL.getWindowSurface window
-  gegl_init
+  G.gegl_init
   -- I think I need some AffectionT or someting similar here and not a RenderT
   -- from SDL.
   inRender renderer $ ops
-  gegl_exit
+  G.gegl_exit
-  destroyWindow window
+  SDL.destroyWindow window
 
-withDefaultWindow :: Monad m => Text -> (RenderT m a) -> IO ()
+withDefaultWindow :: Monad m => T.Text -> (RenderT m a) -> IO ()
-withDefaultWindow title ops = withWindow title defaultWindow defaultRenderer ops
+withDefaultWindow title ops = withWindow title defaultWindow SDL.defaultRenderer ops
 
 delaySec :: Int -> IO ()
-delaySec dur = delay (fromIntegral $ dur * 1000)
+delaySec dur = SDL.delay (fromIntegral $ dur * 1000)

src/Affection/Types.hs

@@ -1,7 +1,86 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
 module Affection.Types
-  ( RGBA(..)
+  ( AffectionData(..)
+  , AffectionConfig(..)
+  -- , AffectionState(..)
+  -- , AffectionDraw(..)
+  -- , Draw(..)
+  , AffectionStateInner(..)
+  -- , AffectionDrawInner(..)
+  , InitComponents(..)
+  -- , Loop(..)
+  , RGBA(..)
+  , SDL.WindowConfig(..)
+  , SDL.defaultWindow
   ) where
 
+import qualified SDL.Init as SDL
+import qualified SDL.Video as SDL
+import qualified Data.Text as T
+
+import Control.Monad.IO.Class
+import Control.Monad.State
+import Control.Monad.Reader
+
+import Control.Concurrent.MVar
+
+-- | Configuration for the aplication. needed at startup.
+data AffectionConfig us = AffectionConfig
+  { initComponents :: InitComponents                            -- ^ SDL components to initialize at startup
+  , windowTitle    :: T.Text                                    -- ^ Window title
+  , windowConfig   :: SDL.WindowConfig                          -- ^ Window configuration
+  , drawLoop       :: AffectionState (AffectionData us) IO (IO ()) -- ^ Some function. Type to be determined.
+  , updateLoop     :: Double -> AffectionState us IO (IO ())       -- ^ Another function. Type to be determined
+  , userData       :: us
+  }
+
+-- | Main type for defining the look, feel and action of the whole application.
+data AffectionData us = AffectionData
+  { affectionConfig :: AffectionConfig us -- ^ Application configuration.
+  , quitEvent       :: Bool               -- ^ Loop breaker.
+  , userState       :: us                 -- ^ State data provided by user
+  , drawWindow      :: SDL.Window         -- ^ SDL window
+  , drawSurface     :: SDL.Surface        -- ^ SDL surface
+  }
+
+-- -- | Data and surfaces for drawing.
+-- data AffectionDraw dd = AffectionDraw
+--   }
+
+-- | Components to initialize in SDL.
+data InitComponents
+  = All
+  | Only [SDL.InitFlag]
+
+-- | Inner 'StateT' monad for the update state
+type AffectionStateInner us m a = StateT (AffectionData us) m a
+
+-- | Affection's state monad
+newtype AffectionState us m a = AffectionState
+  { runState :: AffectionStateInner us m a }
+  deriving (Functor, Applicative, Monad, MonadIO)
+
+-- -- | Inner 'StateT' monad of Affection
+-- type AffectionInner us od a = StateT (AffectionState us od) IO a
+-- 
+-- -- | Affection state monad
+-- newtype Affection us od a = Affection
+--   { runAffection :: AffectionInner us od a }
+--   deriving (Functor, Applicative, Monad, MonadState (AffectionState us od))
+-- 
+-- -- | Inner drawing monad of Affection.
+-- type AffectionDrawInner ds a = ReaderT (Draw ds) a
+-- 
+-- -- | Affectiondrawinf reader monad.
+-- newtype AffectionDraw ds a = AffectionDraw
+--   { runDraw :: (ds -> a) }
+--   deriving (Functor, Applicative, Monad, MonadReader ds)
+-- 
+-- -- | Loop state monad to hold elapsed time per frame
+-- newtype Loop f a = Loop
+--   { runLoop :: f -> (a, f) }
+--   deriving (Functor, Applicative, Monad, MonadState (Loop f))
+
 data RGBA = RGBA
   { r :: Int
   , g :: Int