small update of flake and project URL

Multiwindow

.envrc

@@ -0,0 +1 @@
+use flake

.gitignore

@@ -16,3 +16,5 @@ cabal.project.local*
 dist*/
 report.html
 *.bak
+.direnv/
+result

affection.cabal

@@ -6,7 +6,7 @@ name:                affection
 -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:             0.0.0.9
+version:             0.0.0.10
 synopsis:            A simple Game Engine using SDL
 description:         This package contains Affection, a simple game engine
                      written in Haskell using SDL.
@@ -16,7 +16,7 @@ homepage:            https://github.com/nek0/affection#readme
 license:             LGPL-3
 license-file:        LICENSE
 author:              nek0
-maintainer:          nek0@chelnok.de
+maintainer:          nek0@nek0.eu
 category:            Game
 build-type:          Simple
 extra-source-files:  ChangeLog.md
@@ -25,11 +25,11 @@ extra-source-files:  ChangeLog.md
 -- README.
 -- extra-source-files:  
 
-cabal-version:       >=1.10
+cabal-version:       >=2.0
 
 source-repository head
   type:     git
-  location: https://github.com/nek0/affection
+  location: https://gitea.nek0.eu/nek0/affection.git
 
 flag verbose
   description:       Enable verbose debug messages
@@ -67,6 +67,7 @@ library
   exposed-modules:     Affection
                      , Affection.Logging
                      , Affection.Types
+                     , Affection.Class
                      , Affection.StateMachine
                      , Affection.Util
                      , Affection.MessageBus
@@ -84,35 +85,39 @@ library
                      , Affection.Subsystems.AffectionMouse
                      , Affection.Subsystems.AffectionJoystick
   default-extensions:  OverloadedStrings
+                     , TypeFamilies
+                     , AllowAmbiguousTypes
 
   -- Modules included in this library but not exported.
   -- other-modules:       
   
   -- LANGUAGE extensions used by modules in this package.
-  other-extensions:    GADTs
+  -- other-extensions:    GADTs
-                     , KindSignatures
+  --                    , KindSignatures
-                     , FlexibleInstances
+  --                    , FlexibleInstances
-                     , MultiParamTypeClasses
+  --                    , MultiParamTypeClasses
-                     , UndecidableInstances
+  --                    , UndecidableInstances
   hs-source-dirs:      src
   default-language:    Haskell2010
-  ghc-options:       -Wall
+  ghc-options:       -threaded -Wall
   -- Other library packages from which modules are imported.
   build-depends:       base >=4.9 && < 5
-                     , sdl2 >= 2.4 && < 2.5
+                     , sdl2 >= 2.5
                      , linear
                      , text
                      , mtl
                      , monad-loops
                      , monad-parallel
                      , containers
-                     , clock
+                     , clock >= 0.8
                      , glib
                      , bytestring
                      , OpenGL
+                     , OpenGLRaw
                      , stm
                      , uuid
                      , vector
+                     , resourcet
 
 -- This example shows the message system. only makes sense when compiling with
 -- verbose flag.
@@ -122,12 +127,11 @@ executable example00
   ghc-options:       -threaded -Wall
   default-language:  Haskell2010
   default-extensions: OverloadedStrings
-  if flag(examples)
   build-depends:     base >=4.9 && < 5
                    , affection
-                     , sdl2
+                   , sdl2 >= 2.5
                    , stm
-  else
+  if !flag(examples)
     buildable:       False
 
 -- A small game of life implementation
@@ -138,10 +142,9 @@ executable example01
   ghc-options:       -threaded -Wall
   default-language:  Haskell2010
   default-extensions: OverloadedStrings
-  if flag(examples)
   build-depends:     base >=4.9 && < 5
                    , affection
-                     , sdl2
+                   , sdl2 >= 2.5
                    , stm
                    , OpenGL
                    , random
@@ -150,7 +153,7 @@ executable example01
                    , matrix
                    , nanovg >= 0.6.0.0
                    , deepseq
-  else
+  if !flag(examples)
     buildable:       False
 
 -- Another small game of life implementation
@@ -161,10 +164,9 @@ executable example02
   ghc-options:       -threaded -Wall
   default-language:  Haskell2010
   default-extensions: OverloadedStrings
-  if flag(examples)
   build-depends:     base >=4.9 && < 5
                    , affection
-                     , sdl2
+                   , sdl2 >= 2.5
                    , stm
                    , OpenGL
                    , random
@@ -173,5 +175,5 @@ executable example02
                    , matrix
                    , nanovg >= 0.6.0.0
                    , deepseq
-  else
+  if !flag(examples)
     buildable:       False

cabal.project

@@ -0,0 +1,4 @@
+packages: ./*.cabal
+
+package affection
+  flags: +examples

examples/example00/Main.hs

@@ -1,21 +1,34 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 
+module Main where
+
 import Affection as A
 
 import Control.Concurrent.STM
-import Control.Monad.IO.Class (liftIO)
+import Control.Concurrent.MVar
-import Control.Monad (when)
+import Control.Monad
 
-import qualified SDL hiding (Window(..))
+import qualified SDL
 
 import Data.Maybe (isJust, fromJust)
+import Data.String
 
 data StateData = StateData
   { sdSubs :: Subsystems
-  , sdJoys :: [SDL.Joystick]
+  , sdJoys :: MVar [SDL.Joystick]
+  , doNextStep :: MVar Bool
   }
 
+instance Affectionate StateData where
+  loadState = load
+  preLoop = pre
+  handleEvents = handle
+  update = Main.update
+  draw = Main.draw
+  cleanUp = clean
+  hasNextStep = liftIO . readMVar . doNextStep
+
 data Subsystems = Subsystems
   { subWindow   :: Main.Window
   , subMouse    :: Main.Mouse
@@ -23,36 +36,13 @@ data Subsystems = Subsystems
   , subJoystick :: Main.Joystick
   }
 
-newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
+newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
-newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
+newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection ())])
-newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
+newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
-newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection StateData ())])
+newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection ())])
 
-generalSubscribers
+instance Participant Main.Window where
-  :: TVar [(UUID, msg -> Affection StateData ())]
+  type Mesg Main.Window = WindowMessage
-  -> Affection StateData [msg -> Affection StateData ()]
-generalSubscribers t = do
-  subTups <- liftIO $ readTVarIO t
-  return $ map snd subTups
-
-generalSubscribe
-  :: TVar [(UUID, msg -> Affection StateData ())]
-  -> (msg -> Affection StateData())
-  -> Affection StateData UUID
-generalSubscribe t funct = do
-  uuid <- genUUID
-  liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
-  return uuid
-
-generalUnSubscribe
-  :: TVar [(UUID, msg -> Affection StateData ())]
-  -> UUID
-  -> Affection StateData ()
-generalUnSubscribe t uuid =
-  liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
-
-instance Participant Main.Window StateData where
-  type Mesg Main.Window StateData = WindowMessage
 
   partSubscribers (Window t) = generalSubscribers t
 
@@ -60,11 +50,11 @@ instance Participant Main.Window StateData where
 
   partUnSubscribe (Window t) = generalUnSubscribe t
 
-instance SDLSubsystem Main.Window StateData where
+instance SDLSubsystem Main.Window where
   consumeSDLEvents = consumeSDLWindowEvents
 
-instance Participant Mouse StateData where
+instance Participant Mouse where
-  type Mesg Mouse StateData = MouseMessage
+  type Mesg Mouse = MouseMessage
 
   partSubscribers (Mouse t) = generalSubscribers t
 
@@ -72,11 +62,11 @@ instance Participant Mouse StateData where
 
   partUnSubscribe (Mouse t) = generalUnSubscribe t
 
-instance SDLSubsystem Mouse StateData where
+instance SDLSubsystem Mouse where
   consumeSDLEvents = consumeSDLMouseEvents
 
-instance Participant Keyboard StateData where
+instance Participant Keyboard where
-  type Mesg Keyboard StateData = KeyboardMessage
+  type Mesg Keyboard = KeyboardMessage
 
   partSubscribers (Keyboard t) = generalSubscribers t
 
@@ -84,11 +74,11 @@ instance Participant Keyboard StateData where
 
   partUnSubscribe (Keyboard t) = generalUnSubscribe t
 
-instance SDLSubsystem Keyboard StateData where
+instance SDLSubsystem Keyboard where
   consumeSDLEvents = consumeSDLKeyboardEvents
 
-instance Participant Joystick StateData where
+instance Participant Joystick where
-  type Mesg Joystick StateData = JoystickMessage
+  type Mesg Joystick = JoystickMessage
 
   partSubscribers (Joystick t) = generalSubscribers t
 
@@ -96,7 +86,7 @@ instance Participant Joystick StateData where
 
   partUnSubscribe (Joystick t) = generalUnSubscribe t
 
-instance SDLSubsystem Joystick StateData where
+instance SDLSubsystem Joystick where
   consumeSDLEvents = consumeSDLJoystickEvents
 
 main :: IO ()
@@ -109,21 +99,14 @@ main = do
           [
           ( 0
           , SDL.defaultWindow
-            { SDL.windowOpenGL = Just SDL.defaultOpenGL
+            { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
               { SDL.glProfile = SDL.Core SDL.Normal 3 3
               }
             }
+          , SDL.Windowed
           )
           ]
-        , initScreenMode = SDL.Windowed
+        } :: AffectionConfig StateData
-        , canvasSize = Nothing
-        , loadState = load
-        , preLoop = pre
-        , eventLoop = handle
-        , updateLoop = update
-        , drawLoop = draw
-        , cleanUp = clean
-        }
   withAffection conf
 
 load :: IO StateData
@@ -134,57 +117,80 @@ load =
     <*> (Keyboard <$> newTVarIO [])
     <*> (Joystick <$> newTVarIO [])
     )
-    <*> return []
+    <*> newMVar []
+    <*> newMVar True
 
-pre :: Affection StateData ()
+pre :: StateData -> Affection ()
-pre = do
+pre sd = do
-  sd <- getAffection
+  _ <- partSubscribe (subKeyboard $ sdSubs sd) (exitOnQ (doNextStep sd))
-  _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
+  _ <- partSubscribe (subWindow $ sdSubs sd) (exitOnWindowClose (doNextStep sd))
-  _ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose
+  _ <- partSubscribe (subJoystick $ sdSubs sd) (joyConnectDisconnect (sdJoys sd))
-  _ <- partSubscribe (subJoystick $ sdSubs sd) joyConnectDisconnect
   return ()
 
-exitOnQ :: KeyboardMessage -> Affection StateData ()
+exitOnQ :: MVar Bool -> KeyboardMessage -> Affection ()
-exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
+exitOnQ nextStep (MsgKeyboardEvent _ _ _ _ sym) =
   case SDL.keysymKeycode sym of
     SDL.KeycodeQ -> do
       liftIO $ logIO Debug "Yo dog I heard..."
-      quit
+      void $ liftIO $ swapMVar nextStep False
     _ -> return ()
 
-exitOnWindowClose :: WindowMessage -> Affection StateData ()
+exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
-exitOnWindowClose wm =
+exitOnWindowClose nextStep wm =
   case wm of
     MsgWindowClose _ _ -> do
       liftIO $ logIO Debug "I heard another one..."
-      quit
+      void $ liftIO $ swapMVar nextStep False
     _ -> return ()
 
-joyConnectDisconnect :: JoystickMessage -> Affection StateData ()
+joyConnectDisconnect :: MVar [SDL.Joystick] -> JoystickMessage -> Affection ()
-joyConnectDisconnect msg = do
+joyConnectDisconnect mvjs msg = do
   mj <- joystickAutoConnect msg
   when (isJust mj) $ do
-    sd <- getAffection
+    js <- liftIO $ readMVar mvjs
-    putAffection sd
+    void $ liftIO $ swapMVar mvjs (fromJust mj : js)
-      { sdJoys = fromJust mj : sdJoys sd
+  js <- liftIO $ readMVar mvjs
-      }
+  njs <- joystickAutoDisconnect js msg
-  sd <- getAffection
+  liftIO $ putMVar mvjs njs
-  njs <- joystickAutoDisconnect (sdJoys sd) msg
-  putAffection sd
-    { sdJoys = njs
-    }
 
-handle :: [SDL.EventPayload] -> Affection StateData ()
+handle :: StateData -> [SDL.EventPayload] -> Affection ()
-handle es = do
+handle sd es = do
-  (Subsystems a b c d) <- sdSubs <$> getAffection
+  let (Subsystems a b c d) = sdSubs sd
   leftovers <- consumeSDLEvents a
     =<< consumeSDLEvents b
     =<< consumeSDLEvents c
     =<< consumeSDLEvents d es
-  mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " ++ show e) leftovers
+  mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e))
+    leftovers
 
-update _ = return ()
+update :: StateData -> Double -> Affection ()
+update _ _ = return ()
 
-draw = return ()
+draw :: StateData -> Affection ()
+draw _ = return ()
 
+clean :: StateData -> IO ()
 clean _ = return ()
+
+generalSubscribers
+  :: TVar [(UUID, msg -> Affection ())]
+  -> Affection [msg -> Affection ()]
+generalSubscribers t = do
+  subTups <- liftIO $ readTVarIO t
+  return $ map snd subTups
+
+generalSubscribe
+  :: TVar [(UUID, msg -> Affection ())]
+  -> (msg -> Affection())
+  -> Affection UUID
+generalSubscribe t funct = do
+  uuid <- genUUID
+  liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+  return uuid
+
+generalUnSubscribe
+  :: TVar [(UUID, msg -> Affection ())]
+  -> UUID
+  -> Affection ()
+generalUnSubscribe t uuid =
+  liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))

examples/example01/Main.hs

@@ -3,30 +3,36 @@
 {-# LANGUAGE ForeignFunctionInterface #-}
 
 import Affection as A
-import SDL (($=))
 import qualified SDL
-import qualified Graphics.Rendering.OpenGL as GL
 
 import Control.Concurrent.STM
-import Control.Monad.IO.Class (liftIO)
+import Control.Concurrent.MVar
-import Control.Monad (when)
+import Control.Monad
 import Control.DeepSeq (deepseq)
 
 import Data.Matrix as M
 import qualified Data.Set as S
+import Data.String
 
 import System.Random (randomRIO)
 
 import NanoVG hiding (V2(..))
 
-import Linear
-
 import Foreign.C.Types (CInt(..))
 
 -- internal imports
 
 import Types
 
+instance Affectionate UserData where
+  loadState = load
+  preLoop = pre
+  handleEvents = handle
+  update = Main.update
+  draw = Main.draw
+  cleanUp = clean
+  hasNextStep = liftIO . readMVar . doNextStep
+
 foreign import ccall unsafe "glewInit"
   glewInit :: IO CInt
 
@@ -40,23 +46,16 @@ main = do
           [
           ( 0
           , SDL.defaultWindow
-            { SDL.windowOpenGL = Just SDL.defaultOpenGL
+            { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
               { SDL.glProfile = SDL.Core SDL.Normal 3 3
               }
             , SDL.windowInitialSize = SDL.V2 600 600
             , SDL.windowResizable = True
             }
+          , SDL.Windowed
           )
           ]
-        , initScreenMode = SDL.Windowed
+        } :: AffectionConfig UserData
-        , canvasSize = Nothing
-        , loadState = load
-        , preLoop = pre
-        , eventLoop = handle
-        , updateLoop = update
-        , drawLoop = draw
-        , cleanUp = clean
-        }
   withAffection conf
 
 load :: IO UserData
@@ -65,156 +64,146 @@ load = do
   liftIO $ logIO A.Debug "init GLEW"
   _ <- glewInit
   liftIO $ logIO A.Debug "making random"
-  randList <- mapM (\_ -> randomRIO (0,1)) [0..3599]
+  randList <- mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
   liftIO $ logIO A.Debug "creating context"
   nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
   let fullMatrix = fromList 60 60 randList
   -- logIO A.Debug $ prettyMatrix fullMatrix
-  empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection UserData ())])
+  empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())])
-  empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection UserData ())])
+  empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())])
-  return $ UserData
+  step <- newMVar True
+  (\life food time -> UserData
     { subsystems = Subsystems
       (Window empty1)
       (Keyboard empty3)
-    , lifeMat = fullMatrix
+    , lifeMat = life
-    , foodMat = fromList 60 60 (repeat 10)
+    , foodMat = food
-    , timeMat = M.zero 60 60
+    , timeMat = time
     , nano = nanoCtx
+    , doNextStep = step
     }
+    )
+    <$> newMVar fullMatrix
+    <*> (newMVar (fromList 60 60 (repeat 10)))
+    <*> (newMVar (M.zero 60 60))
 
-pre :: Affection UserData ()
+pre :: UserData -> Affection ()
-pre = do
+pre ud = do
-  sd <- getAffection
+  void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud))
-  _ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc
+  void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud)
-  _ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR
+  void $ partSubscribe (subKeyboard $ subsystems ud) showFPS
-  _ <- partSubscribe (subKeyboard $ subsystems sd) showFPS
+  void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen
-  _ <- partSubscribe (subKeyboard $ subsystems sd) toggleFullScreen
+  void $ partSubscribe (subWindow   $ subsystems ud) (exitOnWindowClose (doNextStep ud))
-  _ <- partSubscribe (subWindow   $ subsystems sd) exitOnWindowClose
+  void $ partSubscribe (subWindow   $ subsystems ud) (fitViewport (600/600))
-  _ <- partSubscribe (subWindow   $ subsystems sd) (fitViewport (600/600))
-  now <- getElapsedTime
-  putAffection sd
 
-toggleFullScreen :: KeyboardMessage -> Affection UserData ()
+toggleFullScreen :: KeyboardMessage -> Affection ()
 toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
-  | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
+  | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
   | otherwise = return ()
 toggleFullScreen _ = return ()
 
-exitOnEsc :: KeyboardMessage -> Affection UserData ()
+exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection ()
-exitOnEsc (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
+exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
   case SDL.keysymKeycode sym of
     SDL.KeycodeEscape -> do
       liftIO $ logIO A.Debug "Yo dog I heard..."
-      quit
+      void $ liftIO $ swapMVar step False
     _ -> return ()
-exitOnEsc _ = return ()
+exitOnEsc _ _ = return ()
 
-reloadOnR :: KeyboardMessage -> Affection UserData ()
+reloadOnR :: UserData -> KeyboardMessage -> Affection ()
-reloadOnR (MsgKeyboardEvent _ _ _ _ sym) =
+reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) =
   case SDL.keysymKeycode sym of
-    SDL.KeycodeR -> reload
+    SDL.KeycodeR -> reload ud
     _ -> return ()
-reloadOnR _ = return ()
 
-reload :: Affection UserData ()
+reload :: UserData -> Affection ()
-reload = do
+reload ud = do
-  ud <- getAffection
+  randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
-  now <- getElapsedTime
-  randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]
   let fullMatrix = fromList 60 60 randList
-  putAffection ud
+  void $ liftIO $ swapMVar (lifeMat ud) fullMatrix
-    { lifeMat = fullMatrix
+  void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat 10))
-    , foodMat = fromList 60 60 (repeat 10)
+  void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60)
-    , timeMat = M.zero 60 60
-    }
 
-showFPS :: KeyboardMessage -> Affection UserData ()
+showFPS :: KeyboardMessage -> Affection ()
 showFPS (MsgKeyboardEvent _ _ _ _ sym) =
   case SDL.keysymKeycode sym of
     SDL.KeycodeF -> do
       dt <- getDelta
-      liftIO $ logIO A.Debug $ "FPS: " ++ show (1 / dt)
+      liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt))
     _ -> return ()
-showFPS _ = return ()
 
-exitOnWindowClose :: WindowMessage -> Affection UserData ()
+exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
-exitOnWindowClose wm =
+exitOnWindowClose step wm =
   case wm of
     MsgWindowClose _ _ -> do
       liftIO $ logIO A.Debug "I heard another one..."
-      quit
+      void $ liftIO $ swapMVar step False
     _ -> return ()
-exitOnWindowClose _ = return ()
 
-handle :: [SDL.EventPayload] -> Affection UserData ()
+handle :: UserData -> [SDL.EventPayload] -> Affection ()
-handle es = do
+handle ud es = do
-  (Subsystems a b) <- subsystems <$> getAffection
+  let (Subsystems a b) = subsystems ud
   _ <- consumeSDLEvents a =<< consumeSDLEvents b es
   return ()
 
-update :: Double -> Affection UserData ()
+update :: UserData -> Double -> Affection ()
-update _ = do
+update ud _ = do
-  ud <- getAffection
+  -- liftIO $ logIO A.Debug ("FPS: " <> fromString (show (1/dt)))
+  pastLife <- liftIO $ readMVar (lifeMat ud)
+  pastFood <- liftIO $ readMVar (foodMat ud)
+  pastTime <- liftIO $ readMVar (timeMat ud)
   newList <- mapM (\coord -> do
     let x = (coord `mod` 60) + 1
         y = (coord `div` 60) + 1
         subm
           | x == 1 && y == 1 =
-            (submatrix 60 60 60 60 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud))
+            (submatrix 60 60 60 60 pastLife <|> submatrix 60 60 1 2 pastLife)
             <->
-            (submatrix 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud))
+            (submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife)
           | x == 1 && y == 60 =
-            (submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud))
+            (submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife)
             <->
-            (submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud))
+            (submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife)
           | x == 60 && y == 1 =
-            (submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud))
+            (submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife)
             <->
-            (submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud))
+            (submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife)
           | x == 60 && y == 60 =
-            (submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud))
+            (submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife)
             <->
-            (submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud))
+            (submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife)
           | x == 1 =
-            (submatrix (y - 1) (y + 1) 60 60 (lifeMat ud))
+            (submatrix (y - 1) (y + 1) 60 60 pastLife)
             <|>
-            (submatrix (y - 1) (y + 1) 1 2 (lifeMat ud))
+            (submatrix (y - 1) (y + 1) 1 2 pastLife)
           | y == 1 =
-            (submatrix 60 60 (x - 1) (x + 1) (lifeMat ud))
+            (submatrix 60 60 (x - 1) (x + 1) pastLife)
             <->
-            (submatrix 1 2 (x - 1) (x + 1) (lifeMat ud))
+            (submatrix 1 2 (x - 1) (x + 1) pastLife)
           | x == 60 =
-            (submatrix (y - 1) (y + 1) 59 60 (lifeMat ud))
+            (submatrix (y - 1) (y + 1) 59 60 pastLife)
             <|>
-            (submatrix (y - 1) (y + 1) 1 1 (lifeMat ud))
+            (submatrix (y - 1) (y + 1) 1 1 pastLife)
           | y == 60 =
-            (submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud))
+            (submatrix 59 60 (x -1 ) (x + 1) pastLife)
             <->
-            (submatrix 1 1 (x - 1) (x + 1) (lifeMat ud))
+            (submatrix 1 1 (x - 1) (x + 1) pastLife)
           | otherwise =
-            (submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud))
+            (submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife)
         life = countLife subm
-        ret
+    if pastLife M.! (y, x) == 1
-          | life == 0 && lifeMat ud M.! (y, x) == 0 =
+    then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0
-            ( 0
+      then return (1, (pastFood M.! (y, x)) - 1, 0)
-            , if timeMat ud M.! (y, x) >= 10
+      else return (0, pastFood M.! (y, x), 0)
-              then min 10 (foodMat ud M.! (y, x) + 1)
+    else if life == 3 && pastFood M.! (y, x) > 0
-              else min 10 (foodMat ud M.! (y, x))
+      then return (1, (pastFood M.! (y, x)) - 1, 0)
-            , timeMat ud M.! (y, x) + 1
-            )
-          | otherwise = (1, 1, 1)
-    if lifeMat ud M.! (y, x) == 1
-    then if (life == 2 || life == 3) && foodMat ud M.! (y, x) > 0
-      then return (1, (foodMat ud M.! (y, x)) - 1, 0)
-      else return (0, foodMat ud M.! (y, x), 0)
-    else if life == 3 && foodMat ud M.! (y, x) > 0
-      then return (1, (foodMat ud M.! (y, x)) - 1, 0)
       else return
-        ( 0
+        ( (0 :: Word)
-        , if timeMat ud M.! (y, x) > 10
+        , if pastTime M.! (y, x) > 10
-          then min 10 ((foodMat ud M.! (y, x)) + 1)
+          then min 10 ((pastFood M.! (y, x)) + 1)
-          else min 10 (foodMat ud M.! (y, x))
+          else min 10 (pastFood M.! (y, x))
-        , timeMat ud M.! (y, x) + 1
+        , pastTime M.! (y, x) + 1
         )
     ) [0..3599]
   let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
@@ -222,22 +211,21 @@ update _ = do
       newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)
   if newLifeMat == M.zero 60 60
   then
-    reload
+    reload ud
-  else
+  else do
-    putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud)
+    ((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ())
-      { lifeMat = newLifeMat
+    void $ liftIO $ swapMVar (lifeMat ud) newLifeMat
-      --, foodMat = newFoodMat
+    void $ liftIO $ swapMVar (timeMat ud) newTimeMat
-      , timeMat = newTimeMat
-      }
 
 countLife :: Matrix Word -> Word
 countLife mat = res - (mat M.! (2, 2))
   where
     res = foldr (flip (+)) 0 mat
 
-draw :: Affection UserData ()
+draw :: UserData -> Affection ()
-draw = do
+draw ud = do
-  ud <- getAffection
+  life <- liftIO $ readMVar (lifeMat ud)
+  food <- liftIO $ readMVar (foodMat ud)
   liftIO $ do
     beginFrame (nano ud) 600 600 1
     save (nano ud)
@@ -245,7 +233,7 @@ draw = do
       let x = coord `mod` 60
           y = coord `div` 60
           ctx = nano ud
-          mult = lifeMat ud M.! (x + 1, y + 1)
+          mult = life M.! (x + 1, y + 1)
       -- logIO A.Debug $ show mult
       beginPath ctx
       rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
@@ -253,10 +241,11 @@ draw = do
       then
         fillColor ctx (rgba 255 255 255 255)
       else
-        fillColor ctx (rgba 0 (fromIntegral $ 25 * (foodMat ud M.! (x+1, y+1))) 0 255)
+        fillColor ctx (rgba 0 (fromIntegral $ 25 * (food M.! (x+1, y+1))) 0 255)
       fill ctx
       ) [0..3599]
     restore (nano ud)
     endFrame (nano ud)
 
+clean :: UserData -> IO ()
 clean _ = return ()

examples/example01/Types.hs

@@ -10,14 +10,15 @@ import Data.Matrix as M
 import NanoVG
 
 import Control.Concurrent.STM
-import Control.Monad.IO.Class (liftIO)
+import Control.Concurrent.MVar
 
 data UserData = UserData
-  { lifeMat    :: Matrix Word
+  { lifeMat    :: MVar (Matrix Word)
-  , foodMat    :: Matrix Word
+  , foodMat    :: MVar (Matrix Word)
-  , timeMat    :: Matrix Word
+  , timeMat    :: MVar (Matrix Word)
   , subsystems :: Subsystems
   , nano       :: Context
+  , doNextStep :: MVar Bool
   }
 
 data Subsystems = Subsystems
@@ -25,12 +26,12 @@ data Subsystems = Subsystems
   , subKeyboard :: Types.Keyboard
   }
 
-newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
+newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
 
-newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
+newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
 
-instance Participant Types.Window UserData where
+instance Participant Types.Window where
-  type Mesg Types.Window UserData = WindowMessage
+  type Mesg Types.Window = WindowMessage
 
   partSubscribers (Window t) = do
     subTups <- liftIO $ readTVarIO t
@@ -40,11 +41,11 @@ instance Participant Types.Window UserData where
 
   partUnSubscribe (Window t) = generalUnSubscribe t
 
-instance SDLSubsystem Types.Window UserData where
+instance SDLSubsystem Types.Window where
   consumeSDLEvents = consumeSDLWindowEvents
 
-instance Participant Keyboard UserData where
+instance Participant Keyboard where
-  type Mesg Keyboard UserData = KeyboardMessage
+  type Mesg Keyboard = KeyboardMessage
 
   partSubscribers (Keyboard t) = do
     subTups <- liftIO $ readTVarIO t
@@ -54,24 +55,24 @@ instance Participant Keyboard UserData where
 
   partUnSubscribe (Keyboard t) = generalUnSubscribe t
 
-instance SDLSubsystem Keyboard UserData where
+instance SDLSubsystem Keyboard where
   consumeSDLEvents = consumeSDLKeyboardEvents
 
 generalSubscribe
-  :: TVar [(UUID, msg -> Affection UserData ())]
+  :: TVar [(UUID, msg -> Affection ())]
-  -> (msg -> Affection UserData ())
+  -> (msg -> Affection ())
-  -> Affection UserData UUID
+  -> Affection UUID
 generalSubscribe t funct = do
   uuid <- genUUID
   liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
   return uuid
 
 generalUnSubscribe
-  :: TVar [(UUID, msg -> Affection UserData ())]
+  :: TVar [(UUID, msg -> Affection ())]
   -> UUID
-  -> Affection UserData ()
+  -> Affection ()
 generalUnSubscribe t uuid =
   liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
   where
-    filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool
+    filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
     filterMsg (u, _) p = u /= p

examples/example02/Main.hs

@@ -3,30 +3,36 @@
 {-# LANGUAGE ForeignFunctionInterface #-}
 
 import Affection as A
-import SDL (($=))
 import qualified SDL
-import qualified Graphics.Rendering.OpenGL as GL
 
 import Control.Concurrent.STM
-import Control.Monad.IO.Class (liftIO)
+import Control.Concurrent.MVar
-import Control.Monad (when)
+import Control.Monad
 import Control.DeepSeq (deepseq)
 
 import Data.Matrix as M
 import qualified Data.Set as S
+import Data.String
 
 import System.Random (randomRIO)
 
 import NanoVG hiding (V2(..))
 
-import Linear
-
 import Foreign.C.Types (CInt(..))
 
 -- internal imports
 
 import Types
 
+instance Affectionate UserData where
+  loadState = load
+  preLoop = pre
+  handleEvents = handle
+  update = Main.update
+  draw = Main.draw
+  cleanUp = clean
+  hasNextStep = liftIO . readMVar . doNextStep
+
 foreign import ccall unsafe "glewInit"
   glewInit :: IO CInt
 
@@ -43,23 +49,16 @@ main = do
           [
           ( 0
           , SDL.defaultWindow
-            { SDL.windowOpenGL = Just SDL.defaultOpenGL
+            { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
               { SDL.glProfile = SDL.Core SDL.Normal 3 3
               }
             , SDL.windowInitialSize = SDL.V2 600 600
             , SDL.windowResizable = True
             }
+          , SDL.Windowed
           )
           ]
-        , initScreenMode = SDL.Windowed
+        } :: AffectionConfig UserData
-        , canvasSize = Nothing
-        , loadState = load
-        , preLoop = pre
-        , eventLoop = handle
-        , updateLoop = update
-        , drawLoop = draw
-        , cleanUp = clean
-        }
   withAffection conf
 
 load :: IO UserData
@@ -68,156 +67,145 @@ load = do
   liftIO $ logIO A.Debug "init GLEW"
   _ <- glewInit
   liftIO $ logIO A.Debug "making random"
-  randList <- mapM (\_ -> randomRIO (0,1)) [0..3599]
+  randList <- mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
   liftIO $ logIO A.Debug "creating context"
   nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
   let fullMatrix = fromList 60 60 randList
   -- logIO A.Debug $ prettyMatrix fullMatrix
-  empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection UserData ())])
+  empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())])
-  empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection UserData ())])
+  empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())])
-  return $ UserData
+  (\life food time nextStep -> UserData
     { subsystems = Subsystems
       (Window empty1)
       (Keyboard empty3)
-    , lifeMat = fullMatrix
+    , lifeMat = life
-    , foodMat = fromList 60 60 (repeat maxFood)
+    , foodMat = food
-    , timeMat = M.zero 60 60
+    , timeMat = time
     , nano = nanoCtx
+    , doNextStep = nextStep
     }
+    )
+    <$> newMVar fullMatrix
+    <*> newMVar (fromList 60 60 (repeat maxFood))
+    <*> newMVar (M.zero 60 60)
+    <*> newMVar True
 
-pre :: Affection UserData ()
+pre :: UserData -> Affection ()
-pre = do
+pre ud = do
-  sd <- getAffection
+  void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud))
-  _ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc
+  void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud)
-  _ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR
+  void $ partSubscribe (subKeyboard $ subsystems ud) showFPS
-  _ <- partSubscribe (subKeyboard $ subsystems sd) showFPS
+  void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen
-  _ <- partSubscribe (subKeyboard $ subsystems sd) toggleFullScreen
+  void $ partSubscribe (subWindow   $ subsystems ud) (exitOnWindowClose (doNextStep ud))
-  _ <- partSubscribe (subWindow   $ subsystems sd) exitOnWindowClose
+  void $ partSubscribe (subWindow   $ subsystems ud) (fitViewport (600/600))
-  _ <- partSubscribe (subWindow   $ subsystems sd) (fitViewport (600/600))
-  now <- getElapsedTime
-  putAffection sd
 
-toggleFullScreen :: KeyboardMessage -> Affection UserData ()
+toggleFullScreen :: KeyboardMessage -> Affection ()
 toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
-  | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
+  | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
   | otherwise = return ()
 toggleFullScreen _ = return ()
 
-exitOnEsc :: KeyboardMessage -> Affection UserData ()
+exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection ()
-exitOnEsc (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
+exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
   case SDL.keysymKeycode sym of
     SDL.KeycodeEscape -> do
       liftIO $ logIO A.Debug "Yo dog I heard..."
-      quit
+      void $ liftIO $ swapMVar step False
     _ -> return ()
-exitOnEsc _ = return ()
+exitOnEsc _ _ = return ()
 
-reloadOnR :: KeyboardMessage -> Affection UserData ()
+reloadOnR :: UserData -> KeyboardMessage -> Affection ()
-reloadOnR (MsgKeyboardEvent _ _ _ _ sym) =
+reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) =
   case SDL.keysymKeycode sym of
-    SDL.KeycodeR -> reload
+    SDL.KeycodeR -> reload ud
     _ -> return ()
-reloadOnR _ = return ()
 
-reload :: Affection UserData ()
+reload :: UserData -> Affection ()
-reload = do
+reload ud = do
-  ud <- getAffection
+  randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
-  now <- getElapsedTime
-  randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]
   let fullMatrix = fromList 60 60 randList
-  putAffection ud
+  void $ liftIO $ swapMVar (lifeMat ud) fullMatrix
-    { lifeMat = fullMatrix
+  void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat maxFood))
-    , foodMat = fromList 60 60 (repeat maxFood)
+  void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60)
-    , timeMat = M.zero 60 60
-    }
 
-showFPS :: KeyboardMessage -> Affection UserData ()
+showFPS :: KeyboardMessage -> Affection ()
 showFPS (MsgKeyboardEvent _ _ _ _ sym) =
   case SDL.keysymKeycode sym of
     SDL.KeycodeF -> do
       dt <- getDelta
-      liftIO $ logIO A.Debug $ "FPS: " ++ show (1 / dt)
+      liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt))
     _ -> return ()
-showFPS _ = return ()
 
-exitOnWindowClose :: WindowMessage -> Affection UserData ()
+exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
-exitOnWindowClose wm =
+exitOnWindowClose step wm =
   case wm of
     MsgWindowClose _ _ -> do
       liftIO $ logIO A.Debug "I heard another one..."
-      quit
+      void $ liftIO $ swapMVar step False
     _ -> return ()
-exitOnWindowClose _ = return ()
 
-handle :: [SDL.EventPayload] -> Affection UserData ()
+handle :: UserData -> [SDL.EventPayload] -> Affection ()
-handle es = do
+handle ud es = do
-  (Subsystems a b) <- subsystems <$> getAffection
+  let (Subsystems a b) = subsystems ud
   _ <- consumeSDLEvents a =<< consumeSDLEvents b es
   return ()
 
-update :: Double -> Affection UserData ()
+update :: UserData -> Double -> Affection ()
-update _ = do
+update ud _ = do
-  ud <- getAffection
+  pastLife <- liftIO $ readMVar (lifeMat ud)
+  pastFood <- liftIO $ readMVar (foodMat ud)
+  pastTime <- liftIO $ readMVar (timeMat ud)
   newList <- mapM (\coord -> do
     let x = (coord `mod` 60) + 1
         y = (coord `div` 60) + 1
         subm
           | x == 1 && y == 1 =
-            (submatrix 60 60 60 60 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud))
+            (submatrix 60 60 60 60 pastLife <|> submatrix 60 60 1 2 pastLife)
             <->
-            (submatrix 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud))
+            (submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife)
           | x == 1 && y == 60 =
-            (submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud))
+            (submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife)
             <->
-            (submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud))
+            (submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife)
           | x == 60 && y == 1 =
-            (submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud))
+            (submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife)
             <->
-            (submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud))
+            (submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife)
           | x == 60 && y == 60 =
-            (submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud))
+            (submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife)
             <->
-            (submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud))
+            (submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife)
           | x == 1 =
-            (submatrix (y - 1) (y + 1) 60 60 (lifeMat ud))
+            (submatrix (y - 1) (y + 1) 60 60 pastLife)
             <|>
-            (submatrix (y - 1) (y + 1) 1 2 (lifeMat ud))
+            (submatrix (y - 1) (y + 1) 1 2 pastLife)
           | y == 1 =
-            (submatrix 60 60 (x - 1) (x + 1) (lifeMat ud))
+            (submatrix 60 60 (x - 1) (x + 1) pastLife)
             <->
-            (submatrix 1 2 (x - 1) (x + 1) (lifeMat ud))
+            (submatrix 1 2 (x - 1) (x + 1) pastLife)
           | x == 60 =
-            (submatrix (y - 1) (y + 1) 59 60 (lifeMat ud))
+            (submatrix (y - 1) (y + 1) 59 60 pastLife)
             <|>
-            (submatrix (y - 1) (y + 1) 1 1 (lifeMat ud))
+            (submatrix (y - 1) (y + 1) 1 1 pastLife)
           | y == 60 =
-            (submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud))
+            (submatrix 59 60 (x -1 ) (x + 1) pastLife)
             <->
-            (submatrix 1 1 (x - 1) (x + 1) (lifeMat ud))
+            (submatrix 1 1 (x - 1) (x + 1) pastLife)
           | otherwise =
-            (submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud))
+            (submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife)
         life = countLife subm
-        ret
+    if pastLife M.! (y, x) == 1
-          | life == 0 && lifeMat ud M.! (y, x) == 0 =
+    then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0
-            ( 0
+      then return (1, (pastFood M.! (y, x)) - 1, 0)
-            , if timeMat ud M.! (y, x) >= 10
+      else return (0, pastFood M.! (y, x), 0)
-              then min 10 (foodMat ud M.! (y, x) + 1)
+    else if life == 3 && pastFood M.! (y, x) > 0
-              else min 10 (foodMat ud M.! (y, x))
+      then return (1, (pastFood M.! (y, x)) - 1, 0)
-            , timeMat ud M.! (y, x) + 1
-            )
-          | otherwise = (1, 1, 1)
-    if lifeMat ud M.! (y, x) == 1
-    then if (life == 2 || life == 3) && foodMat ud M.! (y, x) > 0
-      then return (1, (foodMat ud M.! (y, x)) - 1, 0)
-      else return (0, foodMat ud M.! (y, x), 0)
-    else if life == 3 && foodMat ud M.! (y, x) > 0
-      then return (1, (foodMat ud M.! (y, x)) - 1, 0)
       else return
-        ( 0
+        ( 0 :: Word
-        , if timeMat ud M.! (y, x) > 10
+        , if pastTime M.! (y, x) > 10
-          then min maxFood ((foodMat ud M.! (y, x)) + 1)
+          then min maxFood ((pastFood M.! (y, x)) + 1)
-          else min maxFood (foodMat ud M.! (y, x))
+          else min maxFood (pastFood M.! (y, x))
-        , timeMat ud M.! (y, x) + 1
+        , pastTime M.! (y, x) + 1
         )
     ) [0..3599]
   let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
@@ -225,41 +213,41 @@ update _ = do
       newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)
   if newLifeMat == M.zero 60 60
   then
-    reload
+    reload ud
-  else
+  else do
-    putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud)
+    ((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ())
-      { lifeMat = newLifeMat
+    void $ liftIO $ swapMVar (lifeMat ud) newLifeMat
-      , foodMat = newFoodMat
+    void $ liftIO $ swapMVar (timeMat ud) newTimeMat
-      , timeMat = newTimeMat
+    void $ liftIO $ swapMVar (foodMat ud) newFoodMat
-      }
 
 countLife :: Matrix Word -> Word
 countLife mat = res - (mat M.! (2, 2))
   where
     res = foldr (flip (+)) 0 mat
 
-draw :: Affection UserData ()
+draw :: UserData -> Affection ()
-draw = do
+draw ud = liftIO $ do
-  ud <- getAffection
+    pastLife <- readMVar (lifeMat ud)
-  liftIO $ do
+    pastFood <- readMVar (foodMat ud)
     beginFrame (nano ud) 600 600 1
     save (nano ud)
     mapM_ (\coord -> do
       let x = coord `mod` 60
           y = coord `div` 60
           ctx = nano ud
-          mult = lifeMat ud M.! (x + 1, y + 1)
+          multiplicator = pastLife M.! (x + 1, y + 1)
       -- logIO A.Debug $ show mult
       beginPath ctx
       rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
-      if mult == 1
+      if multiplicator == 1
       then
         fillColor ctx (rgba 255 255 255 255)
       else
-        fillColor ctx (rgba 0 (fromIntegral $ (255 `div` maxFood) * (foodMat ud M.! (x+1, y+1))) 0 255)
+        fillColor ctx (rgba 0 (fromIntegral $ (255 `div` maxFood) * (pastFood M.! (x+1, y+1))) 0 255)
       fill ctx
       ) [0..3599]
     restore (nano ud)
     endFrame (nano ud)
 
+clean :: UserData -> IO ()
 clean _ = return ()

examples/example02/Types.hs

@@ -10,14 +10,15 @@ import Data.Matrix as M
 import NanoVG
 
 import Control.Concurrent.STM
-import Control.Monad.IO.Class (liftIO)
+import Control.Concurrent.MVar
 
 data UserData = UserData
-  { lifeMat    :: Matrix Word
+  { lifeMat    :: MVar (Matrix Word)
-  , foodMat    :: Matrix Word
+  , foodMat    :: MVar (Matrix Word)
-  , timeMat    :: Matrix Word
+  , timeMat    :: MVar (Matrix Word)
   , subsystems :: Subsystems
   , nano       :: Context
+  , doNextStep :: MVar Bool
   }
 
 data Subsystems = Subsystems
@@ -25,12 +26,12 @@ data Subsystems = Subsystems
   , subKeyboard :: Types.Keyboard
   }
 
-newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
+newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
 
-newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
+newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
 
-instance Participant Types.Window UserData where
+instance Participant Types.Window where
-  type Mesg Types.Window UserData = WindowMessage
+  type Mesg Types.Window = WindowMessage
 
   partSubscribers (Window t) = do
     subTups <- liftIO $ readTVarIO t
@@ -40,11 +41,11 @@ instance Participant Types.Window UserData where
 
   partUnSubscribe (Window t) = generalUnSubscribe t
 
-instance SDLSubsystem Types.Window UserData where
+instance SDLSubsystem Types.Window where
   consumeSDLEvents = consumeSDLWindowEvents
 
-instance Participant Keyboard UserData where
+instance Participant Keyboard where
-  type Mesg Keyboard UserData = KeyboardMessage
+  type Mesg Keyboard = KeyboardMessage
 
   partSubscribers (Keyboard t) = do
     subTups <- liftIO $ readTVarIO t
@@ -54,24 +55,24 @@ instance Participant Keyboard UserData where
 
   partUnSubscribe (Keyboard t) = generalUnSubscribe t
 
-instance SDLSubsystem Keyboard UserData where
+instance SDLSubsystem Keyboard where
   consumeSDLEvents = consumeSDLKeyboardEvents
 
 generalSubscribe
-  :: TVar [(UUID, msg -> Affection UserData ())]
+  :: TVar [(UUID, msg -> Affection ())]
-  -> (msg -> Affection UserData ())
+  -> (msg -> Affection ())
-  -> Affection UserData UUID
+  -> Affection UUID
 generalSubscribe t funct = do
   uuid <- genUUID
   liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
   return uuid
 
 generalUnSubscribe
-  :: TVar [(UUID, msg -> Affection UserData ())]
+  :: TVar [(UUID, msg -> Affection ())]
   -> UUID
-  -> Affection UserData ()
+  -> Affection ()
 generalUnSubscribe t uuid =
   liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
   where
-    filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool
+    filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
     filterMsg (u, _) p = u /= p

flake.lock

@@ -0,0 +1,60 @@
+{
+  "nodes": {
+    "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
+      "locked": {
+        "lastModified": 1694529238,
+        "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "ff7b65b44d01cf9ba6a71320833626af21126384",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1700844339,
+        "narHash": "sha256-VRlPYk0eRn1ao75hoA99LGehYhxZH5RlkP1YXpVROHM=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "33576fdfce2d11204067d6cfa99a2f990ef2169a",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-utils": "flake-utils",
+        "nixpkgs": "nixpkgs"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,54 @@
+{
+  description = "A game stub written in Haskell";
+
+  inputs = {
+    nixpkgs.url = "github:NixOS/nixpkgs";
+    flake-utils.url = "github:numtide/flake-utils";
+  };
+
+  outputs = { self, nixpkgs, flake-utils }:
+    flake-utils.lib.eachDefaultSystem (system:
+      let
+        pkgs = nixpkgs.legacyPackages.${system};
+
+        haskellPackages = pkgs.haskellPackages;
+
+        jailbreakUnbreak = pkg:
+          pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
+
+        packageName = "affection";
+      in rec {
+        packages.${packageName} = # (ref:haskell-package-def)
+          haskellPackages.callCabal2nixWithOptions packageName self "--flag examples" {
+            # Dependency overrides go here
+          };
+
+        defaultPackage = self.packages.${system}.${packageName};
+
+        apps = {
+          example00 = {
+            type = "app";
+            program = "${self.packages.${system}.${packageName}}/bin/example00";
+          };
+          example01 = {
+            type = "app";
+            program = "${self.packages.${system}.${packageName}}/bin/example01";
+          };
+          example02 = {
+            type = "app";
+            program = "${self.packages.${system}.${packageName}}/bin/example02";
+          };
+        };
+
+        devShell = haskellPackages.shellFor {
+          packages = p: [ defaultPackage ];
+          withHoogle = true;
+          buildInputs = with haskellPackages; [
+            haskell-language-server
+            ghcid
+            cabal-install
+          ] ++ (builtins.attrValues self.packages.${system});
+        };
+      });
+}
+

notes/TODO.md

@@ -1,9 +0,0 @@
-# TODO
-
-Implement following things in approximately this Order:
-
-* Message bus
-* Console
-* GUI
-* Framework
-* Everything else

shell.nix

@@ -1,123 +1,7 @@
-{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
+{ pkgs ? import <nixpkgs> {}}:
 
 let
-
+  affection = pkgs.haskellPackages.callCabal2nix "affection" (gitignore ./.) {};
-  inherit (nixpkgs) pkgs;
+  gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
-
-  nanovgNeko = with haskellPackages; callPackage (
-    { mkDerivation, base, bytestring, c2hs, containers, glew
-    , hspec, inline-c, libGL, libGLU, QuickCheck, stdenv, text, vector
-    }:
-    mkDerivation {
-      pname = "nanovg";
-      version = "0.6.0.0";
-      src = ../nanovg-hs;
-      isLibrary = true;
-      isExecutable = true;
-      doCheck = false;
-      libraryHaskellDepends = [ base bytestring containers text vector ];
-      librarySystemDepends = [ glew libGL libGLU ];
-      libraryPkgconfigDepends = [ glew ];
-      libraryToolDepends = [ c2hs ];
-      testHaskellDepends = [ base containers hspec inline-c QuickCheck ];
-      homepage = "https://github.com/cocreature/nanovg-hs";
-      description = "Haskell bindings for nanovg";
-      license = stdenv.lib.licenses.isc;
-    }) {};
-
-  glib = with haskellPackages; callPackage(
-    { mkDerivation, base, bytestring, Cabal, containers, glib
-    , stdenv, text, utf8-string
-    }:
-    mkDerivation {
-      pname = "glib";
-      version = "0.13.6.0";
-      sha256 = "4e71062c6a458440294d820e21449aa4666deed2ea233ef5915da7c1d4aee8eb";
-      setupHaskellDepends = [ base Cabal gtk2hs-buildtools ];
-      libraryHaskellDepends = [
-        base bytestring containers text utf8-string
-      ];
-      libraryPkgconfigDepends = [ pkgs.glib ];
-      homepage = "http://projects.haskell.org/gtk2hs/";
-      description = "Binding to the GLIB library for Gtk2Hs";
-      license = stdenv.lib.licenses.lgpl21;
-    }) {};
-
-  gtk2hs-buildtools = with haskellPackages; callPackage(
-    { mkDerivation, alex, array, base, Cabal, containers, directory
-    , filepath, happy, hashtables, pretty, process, random, stdenv
-    }:
-    mkDerivation {
-      pname = "gtk2hs-buildtools";
-      version = "0.13.4.0";
-      src = ../gtk2hs/tools;
-      isLibrary = true;
-      isExecutable = true;
-      enableSeparateDataOutput = true;
-      libraryHaskellDepends = [
-        array base Cabal containers directory filepath hashtables pretty
-        process random
-      ];
-      libraryToolDepends = [ alex happy ];
-      executableHaskellDepends = [ base ];
-      homepage = "http://projects.haskell.org/gtk2hs/";
-      description = "Tools to build the Gtk2Hs suite of User Interface libraries";
-      license = stdenv.lib.licenses.gpl2;
-    }) {};
-
-  sdl2Nek0 = with haskellPackages; callPackage(
-    { mkDerivation, base, bytestring, deepseq, exceptions, linear, SDL2
-    , StateVar, stdenv, text, transformers, vector, weigh
-    }:
-    mkDerivation {
-      pname = "sdl2";
-      version = "2.4.1.0";
-      sha256 = "21a569c0c19f8ff2bbe1cf1d3eb32f65e8143806de353cedd240df5e9d088b5c";
-      isLibrary = true;
-      isExecutable = true;
-      enableSeparateDataOutput = true;
-      libraryHaskellDepends = [
-        base bytestring exceptions linear StateVar text transformers vector
-      ];
-      librarySystemDepends = [ SDL2 ];
-      libraryPkgconfigDepends = [ SDL2 ];
-      testHaskellDepends = [ base deepseq linear vector weigh ];
-      doCheck = false;
-      description = "Both high- and low-level bindings to the SDL library (version 2.0.4+).";
-      license = stdenv.lib.licenses.bsd3;
-    }) {};
-
-  f = { mkDerivation, base, bytestring, clock, containers, deepseq
-      , linear, matrix, monad-loops, monad-parallel, mtl
-      , OpenGL, random, stdenv, stm, text, uuid, vector
-      }:
-      mkDerivation {
-        pname = "affection";
-        version = "0.0.0.9";
-        src = ./.;
-        configureFlags = [ "-fexamples" ];
-        isLibrary = true;
-        isExecutable = true;
-        libraryHaskellDepends = [
-          base bytestring clock containers glib linear monad-loops
-          monad-parallel mtl OpenGL sdl2Nek0 stm text uuid vector
-        ];
-        executableHaskellDepends = [
-          base containers deepseq linear matrix nanovgNeko OpenGL random sdl2Nek0 stm
-        ];
-        homepage = "https://github.com/nek0/affection#readme";
-        description = "A simple Game Engine using SDL";
-        license = stdenv.lib.licenses.lgpl3;
-      };
-
-  haskellPackages = if compiler == "default"
-                       then pkgs.haskellPackages
-                       else pkgs.haskell.packages.${compiler};
-
-  variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
-
-  drv = variant (haskellPackages.callPackage f {});
-
 in
-
+  affection.env
-  if pkgs.lib.inNixShell then drv.env else drv

src/Affection.hs

@@ -1,5 +1,8 @@
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE Strict #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
 module Affection
     ( withAffection
     , get
@@ -13,15 +16,25 @@ import qualified SDL
 import qualified SDL.Raw.Video as SDL (glSetAttribute)
 import qualified SDL.Raw.Enum as SDL
 
+import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
+import qualified Graphics.GL as GLRaw
+
+import Foreign.Marshal.Array
+
+import qualified Data.ByteString as B
+
+import Data.String (fromString)
+
 import System.Clock
 
 import Control.Monad.Loops
 import Control.Monad.State.Strict
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Resource
 
-import Foreign.C.Types (CInt(..))
+-- internal imports
 
 import Affection.Types as A
+import Affection.Class as A
 import Affection.StateMachine as A
 import Affection.Util as A
 import Affection.MessageBus as A
@@ -29,89 +42,144 @@ import Affection.Subsystems as A
 
 import Affection.Logging as A
 
-import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
-
-
 -- | Main function which bootstraps everything else.
 withAffection
-  :: AffectionConfig us -- ^ Configuration of the Game and its engine.
+  :: forall us. (Affectionate us)
+  => AffectionConfig us -- ^ Configuration of the Game and its engine.
   -> IO ()
-withAffection AffectionConfig{..} = do
+withAffection AffectionConfig{..} = runResourceT $ do
   liftIO $ logIO Debug "Affection starting"
   liftIO $ logIO Debug "Initializing SDL"
+
   -- intialiaze SDL
   case initComponents of
     All ->
       SDL.initializeAll
     Only is ->
       SDL.initialize is
+
   -- give SDL render quality
   SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
+
   -- just checking…
-  do
   renderQuality <- SDL.get SDL.HintRenderScaleQuality
   when (renderQuality /= SDL.ScaleLinear) $
-      logIO Warn "Linear texture filtering not enabled!"
+    liftIO $ logIO Warn "Linear texture filtering not enabled!"
+  void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer)))
+
   -- construct window
   liftIO $ logIO Debug "Creating Window(s)"
-  windows <- zip (map fst windowConfigs) <$>
+  windows <-
     mapM
-    (\wc -> SDL.createWindow windowTitle (snd wc))
+      (\(_, sdlWindowConfig, mode) -> do
+        (windowKey, window) <-
+          allocate
+            (SDL.createWindow windowTitle sdlWindowConfig)
+            (\window -> do
+              logIO Debug "Destroying Window"
+              SDL.destroyWindow window
+              )
+        return $ AffectionWindow window windowKey mode
+        )
       windowConfigs
-  mapM_ (SDL.showWindow . snd) windows
+
-  _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
+  -- Show windows
-  contexts <- zip (map fst windows) <$> mapM (SDL.glCreateContext . snd) windows
+  mapM_ (SDL.showWindow . awWindow) windows
-  -- let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfigs
+
-  --     (w, h) = case canvasSize of
+  -- set modes of windows
-  --       Just (cw, ch) -> (cw, ch)
+  mapM_ (\(AffectionWindow window _ mode) -> SDL.setWindowMode window mode) windows
-  --       Nothing       -> (fromIntegral rw, fromIntegral rh)
+
-  mapM_ (flip SDL.setWindowMode initScreenMode . snd) windows
+  -- Make GL context shareable
+  void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
+
+  -- Create OpenGL contexts
+  contexts <-
+    mapM
+      (\(AffectionWindow window _ _) -> do
+        (contextKey, context) <-
+          allocate
+            (SDL.glCreateContext window)
+            (\context -> do
+              logIO Debug "Destroying context"
+              SDL.glDeleteContext context
+              )
+        return $ AffectionContext context contextKey
+        )
+      windows
+
+  -- sync updates with monitor
   -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
-  liftIO $ logIO Debug "Getting Time"
+
+  -- print current used GL Version
+  version <- liftIO $ peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
+  liftIO $ print (B.pack version)
+
   -- get current time
-  execTime <- getTime Monotonic
+  liftIO $ logIO Debug "Getting Time"
+  execTime <- liftIO $ getTime Monotonic
   liftIO $ logIO Debug "Loading initial data container"
-  initContainer <- (\x -> AffectionData
+
-    { quitEvent       = False
+  -- construct game data object from provided Affectionate instance
-    , userState       = x
+  (gameDataKey, gameData) <-
-    , drawWindows     = windows
+    allocate
+      (liftIO $ loadState @us)
+      (liftIO . cleanUp)
+  -- build state container
+  let initContainer = AffectionData
+        { drawWindows     = windows
         , glContext       = contexts
-    , screenMode      = initScreenMode
         , elapsedTime     = 0
         , deltaTime       = 0
         , sysTime         = execTime
         , pausedTime      = False
-    }) <$> loadState
+        }
-  (_, nState) <- runStateT ( A.runState $ do
+
+  -- initialize and run state
+  void $ liftIO $ runAffection initContainer
+      (do
+        liftIO $ logIO Debug "Running Pre-Loop stage"
+
+        -- run preLoop function from Affectionate
+        preLoop gameData
         liftIO $ logIO Debug "Starting Loop"
-    preLoop
+        whileM_ (hasNextStep gameData)
-    whileM_ (not . A.quitEvent <$> get)
           (do
             -- get state
             ad <- get
+
             -- Measure time difference form last run
             now      <- liftIO $ getTime Monotonic
             let lastTime = sysTime ad
+
             -- compute dt and update elapsedTime
-        let !dt = fromIntegral
+            let dt = fromIntegral
                    (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
-            !ne = elapsedTime ad + dt
+                ne = elapsedTime ad + dt
+
+            -- update state data object with new time values
             put $ ad
               { elapsedTime = ne
               , deltaTime = dt
               }
+
             -- poll events
+            liftIO SDL.pumpEvents
             evs <- preHandleEvents =<< liftIO SDL.pollEvents
+
             -- handle events
-        eventLoop evs
+            handleEvents gameData evs
+
             -- execute user defined update loop
-        unless (pausedTime ad) (updateLoop dt)
+            unless (pausedTime ad) (update gameData dt)
-        -- execute user defined draw loop
+
+            -- clear GL buffer >> execute user defined draw loop >> flush GL buffer
             liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
-        drawLoop
+            draw gameData
             liftIO GL.flush
+
             -- actual displaying of newly drawn frame
-        mapM_ (SDL.glSwapWindow . snd) windows
+            mapM_ (SDL.glSwapWindow . awWindow) windows
+
             -- save new time
             ad3 <- get
             when (sysTime ad == sysTime ad3) (
@@ -120,11 +188,17 @@ withAffection AffectionConfig{..} = do
                 }
               )
             )
-    ) initContainer
+        )
+  -- Cleanup works
   liftIO $ logIO Debug "Loop ended. Cleaning"
-  cleanUp $ userState nState
+  release gameDataKey
-  liftIO $ logIO Debug "Destroying Window"
+  -- mapM_ (SDL.glDeleteContext . snd) contexts
-  mapM_ (SDL.glDeleteContext . snd) contexts
+  -- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
-  mapM_ (SDL.destroyWindow . snd) windows
   -- SDL.quit -- <- This causes segfaults depending on hardware
   liftIO $ logIO Debug "This is the end"
+
+runAffection
+  :: AffectionData
+  -> AffectionState AffectionData ResIO a
+  -> IO (a, AffectionData)
+runAffection initialState a = runResourceT $ runStateT (A.runState a) initialState

src/Affection/Class.hs

@@ -0,0 +1,21 @@
+module Affection.Class where
+
+import qualified SDL
+
+import Affection.Types as A
+
+class Affectionate a where
+
+  loadState    :: IO a
+
+  preLoop      :: a -> Affection ()
+
+  handleEvents :: a -> [SDL.EventPayload] -> Affection ()
+
+  update       :: a -> Double -> Affection ()
+
+  draw         :: a -> Affection ()
+
+  cleanUp      :: a -> IO ()
+
+  hasNextStep  :: a -> Affection Bool

src/Affection/Logging.hs

@@ -3,6 +3,8 @@
 -- from "Debug.Trace".
 module Affection.Logging where
 
+import qualified Data.Text as T
+
 import Debug.Trace
 
 -- | The log level definition
@@ -15,38 +17,38 @@ data LogLevel
 -- | Pure logging function
 log
   :: LogLevel -- ^ Log level to log to
-  -> String   -- ^ The message string
+  -> T.Text   -- ^ The message string
   -> a        -- ^ Arbitrary datatype to return
   -> a        -- ^ Returned data
 #if defined(VERBOSE)
-log Verbose s = trace ("VERBOSE: " ++ s)
+log Verbose s = trace ("VERBOSE: " ++ T.unpack s)
 #endif
 #if defined(DEBUG) || defined(VERBOSE)
-log Debug s = trace ("DEBUG: " ++ s)
+log Debug s = trace ("DEBUG: " ++ T.unpack s)
 #endif
 #if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
-log Warn s = trace ("WARN: " ++ s)
+log Warn s = trace ("WARN: " ++ T.unpack s)
 #endif
 #if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
-log Error s = trace ("ERROR: " ++ s)
+log Error s = trace ("ERROR: " ++ T.unpack s)
 #endif
 log _ _ = id
 
 -- | Manadic logging function residing in the 'IO' Monad
 logIO
   :: LogLevel -- ^ Log level to log to
-  -> String   -- ^ The message string
+  -> T.Text   -- ^ The message string
   -> IO ()
 #if defined(VERBOSE)
-logIO Verbose s = traceIO ("VERBOSE: " ++ s)
+logIO Verbose s = traceIO ("VERBOSE: " ++ T.unpack s)
 #endif
 #if defined(DEBUG) || defined(VERBOSE)
-logIO Debug s = traceIO ("DEBUG: " ++ s)
+logIO Debug s = traceIO ("DEBUG: " ++ T.unpack s)
 #endif
 #if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
-logIO Warn s = traceIO ("WARN: " ++ s)
+logIO Warn s = traceIO ("WARN: " ++ T.unpack s)
 #endif
 #if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
-logIO Error s = traceIO ("ERROR: " ++ s)
+logIO Error s = traceIO ("ERROR: " ++ T.unpack s)
 #endif
 logIO _ _ = return ()

src/Affection/MessageBus.hs

@@ -1,9 +1,6 @@
 module Affection.MessageBus
   ( module M
-  , module Msg
   ) where
 
 import Affection.MessageBus.Class as M
 import Affection.MessageBus.Message as M
-
-import Affection.MessageBus.Message as Msg

src/Affection/MessageBus/Class.hs

@@ -17,28 +17,30 @@ import Control.Monad.IO.Class (liftIO)
 import Data.UUID
 import Data.UUID.V4
 
+import Data.String as S (fromString)
+
 import Affection.Logging
 
 -- | This typeclass defines the behaviour of a participant in the message system
-class (Message (Mesg prt us), Show (Mesg prt us)) => Participant prt us where
+class (Message (Mesg prt), Show (Mesg prt)) => Participant prt where
   -- | Message datatype
-  type Mesg prt us :: *
+  type Mesg prt :: *
 
   -- | Function to get the list of subscribers from the participant
   partSubscribers
     :: prt
     -- ^ the 'Participant''s subscriber storage
-    -> Affection us [Mesg prt us -> Affection us ()]
+    -> Affection [Mesg prt -> Affection ()]
     -- ^ List of Subscriber functions
 
   -- | Subscribe to the 'Participant''s events
   partSubscribe
     :: prt
     -- ^ The 'Participant''s subscriber storage
-    -> (Mesg prt us -> Affection us ())
+    -> (Mesg prt -> Affection ())
     -- ^ What to do in case of a 'Message'
     -- (Subscriber function)
-    -> Affection us UUID
+    -> Affection UUID
     -- ^ 'UUID' of the registered subscriber Function
 
   -- | Unsubscribe a Subscriber function from Participant
@@ -47,20 +49,20 @@ class (Message (Mesg prt us), Show (Mesg prt us)) => Participant prt us where
     -- ^ The 'Participant''s subscriber storage to unsubscribe from
     -> UUID
     -- ^ The subscriber function's 'UUID'
-    -> Affection us ()
+    -> Affection ()
 
   -- | Get the 'Participant' to emit a 'Message' on all of its subscribers
   partEmit
     :: prt
     -- ^ The 'Participant''s subscriber storage
-    -> Mesg prt us
+    -> Mesg prt
     -- ^ The 'Message' to emit
-    -> Affection us ()
+    -> Affection ()
   partEmit p m = do
-    liftIO $ logIO Verbose $ "Emitting message: " ++ show m
+    liftIO $ logIO Verbose $ "Emitting message: " <> S.fromString (show m)
     l <- partSubscribers p
     mapM_ ($ m) l
 
 -- | Helper function to generate new 'UUID's
-genUUID :: Affection us UUID
+genUUID :: Affection UUID
 genUUID = liftIO nextRandom

src/Affection/StateMachine.hs

@@ -7,14 +7,14 @@ import Affection.Types
 import qualified SDL
 
 -- | Typeclass for simple scaffolding of a state machine
-class StateMachine a us where
+class StateMachine us a where
   -- | State load routine
-  smLoad   :: a -> Affection us ()
+  smLoad   :: a -> us -> Affection ()
   -- | state update routine
-  smUpdate :: a -> Double -> Affection us ()
+  smUpdate :: a -> us -> Double -> Affection ()
   -- | State event handler routine
-  smEvent  :: a -> [SDL.EventPayload] -> Affection us ()
+  smEvent  :: a -> us -> [SDL.EventPayload] -> Affection ()
   -- | State draw routine
-  smDraw   :: a -> Affection us ()
+  smDraw   :: a -> us -> Affection ()
   -- | State clean routine
-  smClean  :: a -> Affection us ()
+  smClean  :: a -> us -> Affection ()

src/Affection/Subsystems/AffectionJoystick.hs

@@ -13,6 +13,7 @@ import Control.Monad (filterM)
 import Control.Monad.IO.Class (liftIO)
 
 import qualified Data.Vector as V
+import Data.String as S (fromString)
 
 import Foreign.C.Types (CInt(..))
 
@@ -21,15 +22,15 @@ import qualified SDL
 -- | Helper function that consumes all Joystick-related 'SDL.EventPayload's
 -- and emits appropriate 'JoystickMessage's
 consumeSDLJoystickEvents
-  :: forall am us. (Participant am us, Mesg am us ~ JoystickMessage)
+  :: forall am. (Participant am, Mesg am ~ JoystickMessage)
   => am                              -- ^ The message system participant
   -> [SDL.EventPayload]              -- ^ Incoming events
-  -> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
+  -> Affection [SDL.EventPayload] -- ^ Leftover SDL events
 consumeSDLJoystickEvents am = doConsume
   where
     doConsume
       :: [SDL.EventPayload]
-      -> Affection us [SDL.EventPayload]
+      -> Affection [SDL.EventPayload]
     doConsume [] = return []
     doConsume (e:es) = do
       ts <- getElapsedTime
@@ -80,13 +81,14 @@ consumeSDLJoystickEvents am = doConsume
 joystickAutoConnect
   :: JoystickMessage -- ^ Any 'JoystickMessage' will do,
   -- but listens only on 'MsgJoystickDevice' messages
-  -> Affection us (Maybe SDL.Joystick)
+  -> Affection (Maybe SDL.Joystick)
   -- ^ Returns a joystick descriptor, if successful
 joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do
   [descr] <- V.toList <$>
     (V.filter (\(SDL.JoystickDevice _ i) -> i == CInt which) <$>
       SDL.availableJoysticks)
-  logIO Verbose $ "Connecting Joystick " ++ show which ++ " " ++ show descr
+  logIO Verbose $ "Connecting Joystick " <> fromString (show which) <> " " <>
+   fromString (show descr)
   Just <$> SDL.openJoystick descr
 joystickAutoConnect _ = return Nothing
 
@@ -96,19 +98,20 @@ joystickAutoDisconnect
   :: [SDL.Joystick]              -- ^ List of Joystick descriptors
   -> JoystickMessage             -- ^ Any 'JoystickMessage' will do, but listens
                                  -- specifically to 'MsgJoystickDevice' messages
-  -> Affection us [SDL.Joystick] -- ^ Returns altered list of Joystick descriptors
+  -> Affection [SDL.Joystick] -- ^ Returns altered list of Joystick descriptors
 joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) =
   liftIO $ do
     joyIds <- mapM SDL.getJoystickID js
-    logIO Verbose $ "These are the Joysticks connected: " ++ show joyIds
+    logIO Verbose $ "These are the Joysticks connected: " <>
+      fromString (show joyIds)
     d <- filterM (\j -> fmap (== which) (SDL.getJoystickID j)) js
     if not (null d)
     then do
-      logIO Verbose $ "disconnected joysticks: " ++ show (head d)
+      logIO Verbose $ "disconnected joysticks: " <> fromString (show $ head d)
-      logIO Verbose $ "Disconnecting Joystick " ++ show which
+      logIO Verbose $ "Disconnecting Joystick " <> fromString (show which)
       SDL.closeJoystick (head d)
       njoys <- filterM (\j -> return $ head d /= j) js
-      logIO Verbose $ "returning joysticks: " ++ show njoys
+      logIO Verbose $ "returning joysticks: " <> fromString (show njoys)
       return njoys
     else do
       logIO Error $ "Error while disconnecting Joystick"

src/Affection/Subsystems/AffectionKeyboard.hs

@@ -13,10 +13,10 @@ import qualified SDL
 -- | Helper function that consumes all Keyboard-related 'SDL.EventPayload's
 -- and emits appropriate 'KeyboardMessage's
 consumeSDLKeyboardEvents
-  :: forall ak us. (Participant ak us, Mesg ak us ~ KeyboardMessage)
+  :: forall ak. (Participant ak, Mesg ak ~ KeyboardMessage)
   => ak                              -- ^ The message system participant
   -> [SDL.EventPayload]              -- ^ Incoming events
-  -> Affection us [SDL.EventPayload] -- ^ Leftover SDL Events
+  -> Affection [SDL.EventPayload] -- ^ Leftover SDL Events
 consumeSDLKeyboardEvents ak = doConsume
   where
     doConsume [] = return []

src/Affection/Subsystems/AffectionMouse.hs

@@ -15,15 +15,15 @@ import qualified SDL
 -- | Helper funtion that consumes all Mouse-related 'SDL.Eventpayload's
 -- and emits appropriate 'MouseMessage's
 consumeSDLMouseEvents
-  :: forall am us. (Participant am us, Mesg am us ~ MouseMessage)
+  :: forall am. (Participant am, Mesg am ~ MouseMessage)
   => am                              -- ^ The message system participant
   -> [SDL.EventPayload]              -- ^ Incoming events
-  -> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
+  -> Affection [SDL.EventPayload] -- ^ Leftover SDL events
 consumeSDLMouseEvents am = doConsume
   where
     doConsume
       :: [SDL.EventPayload]
-      -> Affection us [SDL.EventPayload]
+      -> Affection [SDL.EventPayload]
     doConsume [] = return []
     doConsume (e:es) = do
       ts <- getElapsedTime

src/Affection/Subsystems/AffectionWindow.hs

@@ -15,16 +15,16 @@ import qualified SDL
 -- | Helper function that consumes all Window-related 'SDL.EventPayload's
 -- and emits appropriate 'WindowMessage's.
 consumeSDLWindowEvents
-  :: forall aw us. (Participant aw us, Mesg aw us ~ WindowMessage)
+  :: forall aw. (Participant aw, Mesg aw ~ WindowMessage)
   => aw                               -- ^ The message system participant
   -> [SDL.EventPayload]               -- ^ Incoming events
-  -> Affection us [SDL.EventPayload]  -- ^ Leftover SDL events
+  -> Affection [SDL.EventPayload]  -- ^ Leftover SDL events
 consumeSDLWindowEvents aw = doConsume
   where
     doConsume
-      :: (Mesg aw us ~ WindowMessage)
+      :: (Mesg aw ~ WindowMessage)
       => [SDL.EventPayload]
-      -> Affection us [SDL.EventPayload]
+      -> Affection [SDL.EventPayload]
     doConsume [] = return []
     doConsume (e:es) = do
       ts <- getElapsedTime

src/Affection/Subsystems/Class.hs

@@ -7,7 +7,7 @@ import Affection.Types
 import qualified SDL
 
 -- | This class denotes a Subsystem to be part of SDL
-class SDLSubsystem s us where
+class SDLSubsystem s where
   -- | Consume the given 'SDL.EventPayload's and return only those not
   -- recognised
-  consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload]
+  consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection [SDL.EventPayload]

src/Affection/Types.hs

@@ -5,6 +5,8 @@ module Affection.Types
   , AffectionData(..)
   , AffectionStateInner
   , AffectionState(..)
+  , AffectionWindow(..)
+  , AffectionContext(..)
   , InitComponents(..)
   , Angle
   -- | SDL reexports
@@ -23,6 +25,7 @@ import qualified Data.Text as T
 
 import Control.Monad.IO.Class
 import Control.Monad.State.Strict
+import Control.Monad.Trans.Resource
 import qualified Control.Monad.Parallel as MP
 
 import System.Clock (TimeSpec)
@@ -35,27 +38,12 @@ data AffectionConfig us = AffectionConfig
       -- ^ Window title
   , windowConfigs  ::
       [
-      ( Word             -- ^ Window identifier
+      ( Word             -- --^ Window identifier
-      , SDL.WindowConfig -- ^ Window config for given window
+      , SDL.WindowConfig -- --^ Window config for given window
+      , SDL.WindowMode   -- -- ^ Window mode to start in
       )
       ]
       -- ^ Window configurations
-  , canvasSize     :: Maybe (Int, Int)
-      -- ^ size of the texture canvas
-  , initScreenMode :: SDL.WindowMode
-      -- ^ Window mode to start in
-  , loadState      :: IO us
-      -- ^ Provide your own load function to create this data.
-  , preLoop        :: Affection us ()
-      -- ^ Actions to be performed, before loop starts
-  , eventLoop      :: [SDL.EventPayload] -> Affection us ()
-      -- ^ Main update function. Takes fractions of a second as input.
-  , updateLoop     :: Double -> Affection us ()
-      -- ^ Main update function. Takes fractions of a second as input.
-  , drawLoop       :: Affection us ()
-      -- ^ Function for updating graphics.
-  , cleanUp        :: us -> IO ()
-      -- ^ Provide your own finisher function to clean your data.
   }
 
 -- | Components to initialize in SDL.
@@ -64,22 +52,9 @@ data InitComponents
   | Only [SDL.InitFlag]
 
 -- | Main type for defining the look, feel and action of the whole application.
-data AffectionData us = AffectionData
+data AffectionData = AffectionData
-  { quitEvent       :: Bool               -- ^ Loop breaker.
+  { drawWindows     :: [ AffectionWindow ]  -- ^ SDL windows
-  , userState       :: us                 -- ^ State data provided by user
+  , glContext       :: [ AffectionContext ] -- ^ OpenGL rendering contexts
-  , drawWindows     ::
-    [
-    ( Word                                -- ^ Window identifier
-    , SDL.Window                          -- ^ Window linked with identifier
-    )
-    ]                                     -- ^ SDL windows
-  , glContext       ::
-    [
-    ( Word                                -- ^ Window identifier
-    , SDL.GLContext                       -- ^ Associated OpenGL context
-    )
-    ]                                     -- ^ OpenGL rendering contexts
-  , screenMode      :: SDL.WindowMode     -- ^ current screen mode
   , elapsedTime     :: Double               -- ^ Elapsed time in seconds
   , deltaTime       :: Double               -- ^ Elapsed time in seconds since last tick
   , sysTime         :: TimeSpec             -- ^ System time (NOT the time on the clock)
@@ -87,15 +62,26 @@ data AffectionData us = AffectionData
   }
 
 -- | Inner 'StateT' monad for the update state
-type AffectionStateInner us a = StateT us a
+type AffectionStateInner sd m = StateT sd m
 
 -- | Affection's state monad
-newtype AffectionState us m a = AffectionState
+newtype AffectionState sd m a = AffectionState
-  { runState :: AffectionStateInner us m a }
+  { runState :: AffectionStateInner sd m a }
-  deriving (Functor, Applicative, Monad, MonadIO, MonadState us)
+  deriving (Functor, Applicative, Monad, MonadIO, MonadState sd, MonadResource)
 
-instance MP.MonadParallel m => MP.MonadParallel (AffectionState us m)
+instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
 
-type Affection us a = AffectionState (AffectionData us) IO a
+type Affection a = AffectionState AffectionData ResIO a
 
 type Angle = Double
+
+data AffectionWindow = AffectionWindow
+  { awWindow     :: SDL.Window
+  , awReleaseKey :: ReleaseKey
+  , awMode       :: SDL.WindowMode
+  }
+
+data AffectionContext = AffectionContext
+  { acContext    :: SDL.GLContext
+  , acReleaseKey :: ReleaseKey
+  }

src/Affection/Util.hs

@@ -10,26 +10,16 @@ import qualified Graphics.Rendering.OpenGL as GL
 
 import System.Clock
 
+import Data.String (fromString)
+import Data.List (find)
+
 import Control.Monad.State
 
 -- | Prehandle SDL events
-preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload]
+preHandleEvents :: [SDL.Event] -> Affection [SDL.EventPayload]
 preHandleEvents evs =
   return $ map SDL.eventPayload evs
 
--- | Return the userstate to the user
-getAffection :: Affection us us
-getAffection = gets userState
-
--- | Put altered user state back
-putAffection
-  :: us              -- User state
-  -> Affection us ()
-putAffection us = do
-  ad <- get
-  put $ ad
-    { userState = us }
-
 -- | block a thread for a specified amount of time
 delaySec
   :: Int -- ^ Number of seconds
@@ -37,46 +27,54 @@ delaySec
 delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
 
 -- | Get time since start but always the same in the current tick.
-getElapsedTime :: Affection us Double
+getElapsedTime :: Affection Double
 getElapsedTime = gets elapsedTime
 
 -- | Get delta time (time elapsed from last frame)
-getDelta :: Affection us Double
+getDelta :: Affection Double
 getDelta = gets deltaTime
 
--- | Quit the engine loop
-quit :: Affection us ()
-quit = do
-  ad <- get
-  put $ ad { quitEvent = True }
-
 -- | Toggle the Screen mode between 'SDL.Windowed' and 'SDL.FullscreenDesktop'.
 -- Pauses the Engine in the process.
-toggleScreen :: Affection us ()
+toggleScreen :: Word -> Affection ()
-toggleScreen = do
+toggleScreen windowIdent = do
   ad <- get
-  newMode <- case screenMode ad of
+  (stop, alteredWindowList) <- foldM
-    SDL.Windowed -> do
+    (\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do
-      mapM_ (flip SDL.setWindowMode SDL.FullscreenDesktop . snd) (drawWindows ad)
+      if stop || num == windowIdent
-      return SDL.FullscreenDesktop
+      then do
+        newMode <- case mode of
           SDL.FullscreenDesktop -> do
-      mapM_ (flip SDL.setWindowMode SDL.Windowed . snd) (drawWindows ad)
+            liftIO $ SDL.setWindowMode window SDL.Windowed
             return SDL.Windowed
+          SDL.Windowed -> do
+            liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop
+            return SDL.FullscreenDesktop
           x -> do
-      liftIO $ logIO Warn ("Unexpected Screen mode: " ++ show x)
+            liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
             return x
+        return (True, resWindows ++ [aw { awMode = newMode }])
+      else
+        return (stop, resWindows ++ [aw])
+      )
+    (False, [])
+    (zip [0..] (drawWindows ad))
+  if stop
+  then do
     now <- liftIO $ getTime Monotonic
     put ad
       { sysTime = now
-    , screenMode = newMode
+      , drawWindows = alteredWindowList
       }
+  else
+    liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
 
 -- | Fit the GL Viewport to Window size
 fitViewport
   :: Double               -- ^ Image Ratio (width / height)
   -> WindowMessage        -- ^ Incoming Message. Listens only on
                           -- 'MsgWindowResize' and ignores all others.
-  -> Affection us ()
+  -> Affection ()
 fitViewport ratio (MsgWindowResize _ _ (SDL.V2 w h)) = do
   liftIO $ logIO Verbose "Fitting Viewport to size"
   if (fromIntegral w / fromIntegral h) > ratio