.envrc

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

.gitignore

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

affection.cabal

@@ -16,7 +16,7 @@ homepage:            https://github.com/nek0/affection#readme
 license:             LGPL-3
 license-file:        LICENSE
 author:              nek0
-maintainer:          nek0@nek0.eu
+maintainer:          nek0@chelnok.de
 category:            Game
 build-type:          Simple
 extra-source-files:  ChangeLog.md
@@ -29,7 +29,7 @@ cabal-version:       >=2.0
 
 source-repository head
   type:     git
-  location: https://gitea.nek0.eu/nek0/affection.git
+  location: https://github.com/nek0/affection
 
 flag verbose
   description:       Enable verbose debug messages
@@ -99,10 +99,10 @@ library
   --                    , UndecidableInstances
   hs-source-dirs:      src
   default-language:    Haskell2010
-  ghc-options:       -threaded -Wall
+  ghc-options:       -Wall
   -- Other library packages from which modules are imported.
   build-depends:       base >=4.9 && < 5
-                     , sdl2 >= 2.5
+                     , sdl2 ^>= 2.5
                      , linear
                      , text
                      , mtl
@@ -113,11 +113,9 @@ library
                      , glib
                      , bytestring
                      , OpenGL
-                     , OpenGLRaw
                      , stm
                      , uuid
                      , vector
-                     , resourcet
 
 -- This example shows the message system. only makes sense when compiling with
 -- verbose flag.
@@ -127,11 +125,12 @@ executable example00
   ghc-options:       -threaded -Wall
   default-language:  Haskell2010
   default-extensions: OverloadedStrings
+  if flag(examples)
     build-depends:     base >=4.9 && < 5
                      , affection
-                   , sdl2 >= 2.5
+                     , sdl2 ^>= 2.5
                      , stm
-  if !flag(examples)
+  else
     buildable:       False
 
 -- A small game of life implementation
@@ -142,9 +141,10 @@ executable example01
   ghc-options:       -threaded -Wall
   default-language:  Haskell2010
   default-extensions: OverloadedStrings
+  if flag(examples)
     build-depends:     base >=4.9 && < 5
                      , affection
-                   , sdl2 >= 2.5
+                     , sdl2 ^>= 2.5
                      , stm
                      , OpenGL
                      , random
@@ -153,7 +153,7 @@ executable example01
                      , matrix
                      , nanovg >= 0.6.0.0
                      , deepseq
-  if !flag(examples)
+  else
     buildable:       False
 
 -- Another small game of life implementation
@@ -164,9 +164,10 @@ executable example02
   ghc-options:       -threaded -Wall
   default-language:  Haskell2010
   default-extensions: OverloadedStrings
+  if flag(examples)
     build-depends:     base >=4.9 && < 5
                      , affection
-                   , sdl2 >= 2.5
+                     , sdl2 ^>= 2.5
                      , stm
                      , OpenGL
                      , random
@@ -175,5 +176,5 @@ executable example02
                      , matrix
                      , nanovg >= 0.6.0.0
                      , deepseq
-  if !flag(examples)
+  else
     buildable:       False

cabal.project

@@ -1,4 +1,4 @@
-packages: ./*.cabal
+constraints: affection +verbose
-
+profiling: true
-package affection
+packages:
-  flags: +examples
+  ./.

default.nix

@@ -0,0 +1,18 @@
+{ pkgs ? import <nixpkgs> (import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz))
+, haskellCompiler ? "ghc865"
+}:
+  pkgs.haskell-nix.cabalProject {
+    src = pkgs.haskell-nix.haskellLib.cleanGit { src = pkgs.nix-gitignore.gitignoreSource [] ./.; };
+    ghc = pkgs.buildPackages.pkgs.haskell-nix.compiler.${haskellCompiler};
+    # pkg-def-extras = [
+    #   # Additional packages ontop of all those listed in `cabal.project`
+    # ];
+    # modules = [
+    #   # Specific package overrides would go here for example:
+    #   packages.cbors.package.ghcOptions = "-Werror";
+    #   packages.cbors.patches = [ ./one.patch ];
+    #   packages.cbors.flags.optimize-gmp = false;
+    #   # It may be better to set flags in `cabal.project` instead
+    #   # (`plan-to-nix` will include them as defaults).
+    # ];
+  }

flake.lock

@@ -1,60 +0,0 @@
-{
-  "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

@@ -1,54 +0,0 @@
-{
-  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

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

shell.nix

@@ -1,7 +1,125 @@
-{ pkgs ? import <nixpkgs> {}}:
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
 
 let
-  affection = pkgs.haskellPackages.callCabal2nix "affection" (gitignore ./.) {};
+
-  gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir;
+  inherit (nixpkgs) pkgs;
+
+  nanovg = 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";
+      sha256 = "e35a2772f2a2e71916013cab70eeb8eedd6f66b5490ddf7ce237c8c76895d496";
+      revision = "1";
+      editedCabalFile = "1lhfsq50r9bdby7mfscw8ih3wsz2m19lr2a2z9b6diaf5kz76vij";
+      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, gtk2hs-buildtools
+    }:
+    mkDerivation {
+      pname = "glib";
+      version = "0.13.8.0";
+      sha256 = "9cce6fb44e3c30de2bd330a6902955e3a5fce7b6e9ce41a4afb70e3a7d6e61a2";
+      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;
+  #  }) {};
+
+  sdl2 = with haskellPackages; callPackage(
+    { mkDerivation, base, bytestring, deepseq, exceptions, linear, SDL2
+    , StateVar, stdenv, text, transformers, vector, weigh
+    }:
+    mkDerivation {
+      pname = "sdl2";
+      version = "2.5.1.0";
+      sha256 = "fc1d3d4276b2c4f835a5311075abb240385aae7edad8760f6bda55ed8271ed20";
+      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 ];
+      description = "Both high- and low-level bindings to the SDL library (version 2.0.6+).";
+      license = stdenv.lib.licenses.bsd3;
+      doCheck = false;
+    }) {};
+
+  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 sdl2 stm text uuid vector
+        ];
+        executableHaskellDepends = [
+          base containers deepseq linear matrix nanovg OpenGL random sdl2 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,6 @@
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE Strict #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeApplications #-}
@@ -16,22 +17,10 @@ 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.Trans.Resource
-
--- internal imports
 
 import Affection.Types as A
 import Affection.Class as A
@@ -42,88 +31,50 @@ 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
   :: forall us. (Affectionate us)
   => AffectionConfig us -- ^ Configuration of the Game and its engine.
   -> IO ()
-withAffection AffectionConfig{..} = runResourceT $ do
+withAffection AffectionConfig{..} = 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) $
-    liftIO $ logIO Warn "Linear texture filtering not enabled!"
+      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 <-
+  windows <- zip3 (map (\(x,_,_) -> x) windowConfigs) <$>
     mapM
-      (\(_, sdlWindowConfig, mode) -> do
+    (\wc -> SDL.createWindow windowTitle ((\(_,y,_) -> y) wc))
-        (windowKey, window) <-
+    windowConfigs <*>
-          allocate
+    pure (map (\(_,_,z) -> z) windowConfigs)
-            (SDL.createWindow windowTitle sdlWindowConfig)
-            (\window -> do
-              logIO Debug "Destroying Window"
-              SDL.destroyWindow window
-              )
-        return $ AffectionWindow window windowKey mode
-        )
-      windowConfigs
 
-  -- Show windows
+  mapM_ (SDL.showWindow . (\(_,y,_) -> y)) windows
-  mapM_ (SDL.showWindow . awWindow) windows
+  _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
-
+  contexts <- zip (map (\(x,_,_) -> x) windows) <$>
-  -- set modes of windows
+    mapM (SDL.glCreateContext . (\(_,y,_) -> y)) windows
-  mapM_ (\(AffectionWindow window _ mode) -> SDL.setWindowMode window mode) windows
+  mapM_ (\w -> flip SDL.setWindowMode  ((\(_,_,z) -> z) w) ((\(_,y,_) -> y) w)) 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
-
-  -- print current used GL Version
-  version <- liftIO $ peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
-  liftIO $ print (B.pack version)
-
-  -- get current time
   liftIO $ logIO Debug "Getting Time"
-  execTime <- liftIO $ getTime Monotonic
+  -- get current time
+  execTime <- getTime Monotonic
   liftIO $ logIO Debug "Loading initial data container"
-
   -- construct game data object from provided Affectionate instance
-  (gameDataKey, gameData) <-
+  gameData <- loadState @us
-    allocate
-      (liftIO $ loadState @us)
-      (liftIO . cleanUp)
   -- build state container
   let initContainer = AffectionData
         { drawWindows     = windows
@@ -133,53 +84,41 @@ withAffection AffectionConfig{..} = runResourceT $ do
         , sysTime         = execTime
         , pausedTime      = False
         }
-
   -- initialize and run state
-  void $ liftIO $ runAffection initContainer
+  (_, _) <- runStateT
+    (A.runState
       (do
-        liftIO $ logIO Debug "Running Pre-Loop stage"
+        liftIO $ logIO Debug "Starting Loop"
-
         -- run preLoop function from Affectionate
         preLoop gameData
-        liftIO $ logIO Debug "Starting Loop"
         whileM_ (hasNextStep gameData)
           (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
             handleEvents gameData evs
-
             -- execute user defined update loop
             unless (pausedTime ad) (update gameData dt)
-
             -- clear GL buffer >> execute user defined draw loop >> flush GL buffer
             liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
             draw gameData
             liftIO GL.flush
-
             -- actual displaying of newly drawn frame
-            mapM_ (SDL.glSwapWindow . awWindow) windows
+            mapM_ (SDL.glSwapWindow . (\(_,y,_) -> y)) windows
-
             -- save new time
             ad3 <- get
             when (sysTime ad == sysTime ad3) (
@@ -189,16 +128,11 @@ withAffection AffectionConfig{..} = runResourceT $ do
               )
             )
         )
-  -- Cleanup works
+      ) initContainer
   liftIO $ logIO Debug "Loop ended. Cleaning"
-  release gameDataKey
+  cleanUp gameData
-  -- mapM_ (SDL.glDeleteContext . snd) contexts
+  liftIO $ logIO Debug "Destroying Window"
-  -- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
+  mapM_ (SDL.glDeleteContext . snd) contexts
+  mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) 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/MessageBus.hs

@@ -1,6 +1,9 @@
 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/StateMachine.hs

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

src/Affection/Types.hs

@@ -5,8 +5,6 @@ module Affection.Types
   , AffectionData(..)
   , AffectionStateInner
   , AffectionState(..)
-  , AffectionWindow(..)
-  , AffectionContext(..)
   , InitComponents(..)
   , Angle
   -- | SDL reexports
@@ -25,7 +23,6 @@ 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)
@@ -53,8 +50,19 @@ data InitComponents
 
 -- | Main type for defining the look, feel and action of the whole application.
 data AffectionData = AffectionData
-  { drawWindows     :: [ AffectionWindow ]  -- ^ SDL windows
+  { drawWindows     ::
-  , glContext       :: [ AffectionContext ] -- ^ OpenGL rendering contexts
+    [
+    ( Word                                -- --^ Window identifier
+    , SDL.Window                          -- --^ Window linked with identifier
+    , SDL.WindowMode                      -- -- ^ current screen mode
+    )
+    ]                                     -- ^ SDL windows
+  , glContext       ::
+    [
+    ( Word                                -- --^ Window identifier
+    , SDL.GLContext                       -- --^ Associated OpenGL context
+    )
+    ]                                     -- ^ OpenGL rendering contexts
   , 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)
@@ -62,26 +70,15 @@ data AffectionData = AffectionData
   }
 
 -- | Inner 'StateT' monad for the update state
-type AffectionStateInner sd m = StateT sd m
+type AffectionStateInner sd a = StateT sd a
 
 -- | Affection's state monad
 newtype AffectionState sd m a = AffectionState
   { runState :: AffectionStateInner sd m a }
-  deriving (Functor, Applicative, Monad, MonadIO, MonadState sd, MonadResource)
+  deriving (Functor, Applicative, Monad, MonadIO, MonadState sd)
 
 instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
 
-type Affection a = AffectionState AffectionData ResIO a
+type Affection a = AffectionState AffectionData IO 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

@@ -39,34 +39,31 @@ getDelta = gets deltaTime
 toggleScreen :: Word -> Affection ()
 toggleScreen windowIdent = do
   ad <- get
-  (stop, alteredWindowList) <- foldM
+  let mwindow = find (\(ident, _, _) -> ident == windowIdent) (drawWindows ad)
-    (\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do
+  case mwindow of
-      if stop || num == windowIdent
+    Just (ident, window, mode) -> do
-      then do
       newMode <- case mode of
         SDL.FullscreenDesktop -> do
-            liftIO $ SDL.setWindowMode window SDL.Windowed
+          SDL.setWindowMode window SDL.Windowed
           return SDL.Windowed
         SDL.Windowed -> do
-            liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop
+          SDL.setWindowMode window SDL.FullscreenDesktop
           return SDL.FullscreenDesktop
         x -> do
           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
-      , drawWindows = alteredWindowList
+        , drawWindows = map
+          (\e@(lid, win, _) ->
+            if lid == ident
+            then (lid, win, newMode)
+            else e
+            )
+          (drawWindows ad)
         }
-  else
+    Nothing -> do
       liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
 
 -- | Fit the GL Viewport to Window size