bump module Util to affection 0.0.0.10

src/Util.hs

@@ -12,7 +12,9 @@ import Data.Maybe
 import qualified Data.Text as T
 import Data.String
 
-import Control.Monad (join, when)
+import Control.Monad
+
+import Control.Concurrent.MVar
 
 import qualified SDL
 import qualified Graphics.Rendering.OpenGL as GL hiding (get)
@@ -221,7 +223,8 @@ drawLoadScreen ud (progress, msg) = do
   save ctx
   fillColor ctx (rgb 255 128 0)
   fontSize ctx 100
-  fontFace ctx (assetFonts ud Map.! FontBedstead)
+  fonts <- readMVar (assetFonts ud)
+  fontFace ctx (fonts Map.! FontBedstead)
   textAlign ctx (S.fromList [AlignCenter, AlignTop])
   textBox ctx 0 300 1280 "Loading"
   beginPath ctx
@@ -304,48 +307,47 @@ rotVec (V2 x y) deg = V2 nx ny
 dtor :: (Num a, Floating a) => a -> a
 dtor = (pi / 180 *)
 
-cacheJoypad :: JoystickMessage -> Affection ()
+cacheJoypad :: UserData -> JoystickMessage -> Affection ()
-cacheJoypad msg = do
+cacheJoypad ud msg = do
-  ud <- getAffection
+  joy <- liftIO $ readMVar (joyCache ud)
-  putAffection ud
+  void $ liftIO $ swapMVar (joyCache ud) (msg : joy)
-    { joyCache = msg : joyCache ud
-    }
 
-emitJoyActionMessage :: JoystickMessage -> Affection ()
+emitJoyActionMessage :: UserData -> JoystickMessage -> Affection ()
-emitJoyActionMessage (MsgJoystickAxis time _ axis val) = do
+emitJoyActionMessage ud message = do
-  ud <- getAffection
+  trans <- liftIO $ readMVar (translation ud)
-  case translation ud of
+  case message of
-    JoyTranslation tmap -> do
+    MsgJoystickAxis time _ axis val -> do
+      case trans of
+        JoyTranslation tmap -> do
+          let Subsystems _ _ _ _ t = subsystems ud
+              vnormal = fromIntegral val / 32768
+              sigvnormal = abs vnormal
+              align
+                | signum vnormal >= 0 = AxisPositive
+                | signum vnormal < 0 = AxisNegative
+          case tmap Map.!? (AxisAction axis align) of
+            Just (ActUp _)    -> partEmit t (ActionMessage (ActUp sigvnormal) time)
+            Just (ActDown _)  -> partEmit t (ActionMessage (ActDown sigvnormal) time)
+            Just (ActLeft _)  -> partEmit t (ActionMessage (ActLeft sigvnormal) time)
+            Just (ActRight _) -> partEmit t (ActionMessage (ActRight sigvnormal) time)
+            _              -> return ()
+        _ -> return ()
+    MsgJoystickButton time _ but SDL.JoyButtonPressed -> do
       let Subsystems _ _ _ _ t = subsystems ud
-          vnormal = fromIntegral val / 32768
+      case trans of
-          sigvnormal = abs vnormal
+        JoyTranslation tmap -> do
-          align
+          case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of
-            | signum vnormal >= 0 = AxisPositive
+            Just act -> partEmit t (ActionMessage act time)
-            | signum vnormal < 0 = AxisNegative
+            _        -> return ()
-      case tmap Map.!? (AxisAction axis align) of
+        _ -> return ()
-        Just (ActUp _)    -> partEmit t (ActionMessage (ActUp sigvnormal) time)
-        Just (ActDown _)  -> partEmit t (ActionMessage (ActDown sigvnormal) time)
-        Just (ActLeft _)  -> partEmit t (ActionMessage (ActLeft sigvnormal) time)
-        Just (ActRight _) -> partEmit t (ActionMessage (ActRight sigvnormal) time)
-        _              -> return ()
     _ -> return ()
-emitJoyActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
-  ud <- getAffection
-  let Subsystems _ _ _ _ t = subsystems ud
-  case (translation ud) of
-    JoyTranslation tmap -> do
-      case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of
-        Just act -> partEmit t (ActionMessage act time)
-        _        -> return ()
-    _ -> return ()
-emitJoyActionMessage _ = return ()
 
-emitKbdActionMessage :: KeyboardMessage -> Affection ()
+emitKbdActionMessage :: UserData -> KeyboardMessage -> Affection ()
-emitKbdActionMessage (MsgKeyboardEvent time _ press False sym) = do
+emitKbdActionMessage ud (MsgKeyboardEvent time _ press False sym) = do
-  ud <- getAffection
   let Subsystems _ _ _ _ t = subsystems ud
       val = if press == SDL.Pressed then 1 else 0
-  case (translation ud) of
+  trans <- liftIO $ readMVar (translation ud)
+  case trans of
     KbdTranslation tmap -> do
       case tmap Map.!? SDL.keysymKeycode sym of
         Just (ActUp _)    -> partEmit t (ActionMessage (ActUp val) time)
@@ -355,13 +357,12 @@ emitKbdActionMessage (MsgKeyboardEvent time _ press False sym) = do
         Just act -> when (press == SDL.Pressed) (partEmit t (ActionMessage act time))
         _        -> return ()
     _ -> return ()
-emitKbdActionMessage _ = return ()
+emitKbdActionMessage _ _ = return ()
 
-fullClean :: Affection ()
+fullClean :: UserData -> Affection ()
-fullClean = do
+fullClean ud = do
-  ud <- getAffection
   let Subsystems w m k j t = subsystems ud
-      toClean              = uuid ud
+  toClean <- liftIO $ readMVar $ uuid ud
   mapM_ (\u -> do
     partUnSubscribe w u
     partUnSubscribe m u
@@ -369,6 +370,4 @@ fullClean = do
     partUnSubscribe j u
     partUnSubscribe t u
     ) toClean
-  putAffection ud
+  void $ liftIO $ swapMVar (uuid ud) []
-    { uuid = []
-    }