bumped module Menu.Adjust to affection 0.0.0.10

src/Menu/Adjust.hs

@@ -10,98 +10,74 @@ import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 import Data.List (find)
 import Data.Maybe (fromJust, isJust)
-import Data.String
+import Data.String (fromString)
+
+import Control.Monad
+
+import Control.Concurrent.MVar
 
 -- internal imports
 
 import Types
 import Util
 
-loadAdjust :: Action -> Controller -> Affection UserData () -> Affection UserData ()
+loadAdjust :: UserData -> Action -> Controller -> Affection () -> Affection ()
-loadAdjust sub contr switchBack = do
+loadAdjust ud sub contr switchBack = do
-  ud <- getAffection
+  let Subsystems _ _ _ j _ = subsystems ud
-  let Subsystems w m k j t = subsystems ud
+  uu1 <- partSubscribe j (joyListener ud switchBack)
-  uu1 <- partSubscribe j (joyListener switchBack)
+  void $ liftIO $ swapMVar (state ud) (Menu (Adjust sub contr))
-  putAffection ud
+  void $ liftIO $ swapMVar (uuid ud) [uu1]
-    { state = Menu (Adjust sub contr)
-    , uuid = [ uu1 ]
-    }
 
-joyListener :: Affection UserData () -> JoystickMessage -> Affection UserData ()
+joyListener :: UserData -> Affection () -> JoystickMessage -> Affection ()
-joyListener switchBack (MsgJoystickAxis _ _ axis val) = do
+joyListener ud switchBack message = do
-  ud <- getAffection
+  curState <- liftIO $ readMVar (state ud)
-  liftIO $ logIO
+  trans <- liftIO $ readMVar (translation ud)
-    A.Debug
+  case message of
-    ("switching " <>
+    MsgJoystickAxis _ _ axis val -> do
-      fromString (show $ state ud) <>
+      let align
-      " to " <>
-      fromString (show axis)
-      )
-  let trans = translation ud
-      align
             | val > 0 = AxisPositive
             | val < 0 = AxisNegative
             | otherwise = A.log A.Error "Can not assign neitral axis align" (error "*dies*")
       case trans of
         JoyTranslation tmap -> do
-      case state ud of
+          let (Menu (Adjust cact (Joystick _))) = curState
-        Menu (Adjust (ActUp s) (Joystick _)) -> do
+              act = case cact of
-          let k = fst <$> find (\(_, v) -> v == ActUp 1) (M.assocs tmap)
+                ActUp _ -> ActUp 1
-          putAffection ud
+                ActDown _ -> ActDown 1
-            { translation = JoyTranslation $
+                ActLeft _ -> ActLeft 1
-              M.insert (AxisAction (fromIntegral axis) align) (ActUp 1) $
+                ActRight _ -> ActRight 1
-                if isJust k then M.delete (fromJust k) (tmap) else tmap
+                x -> A.log A.Error (fromString (show x) <> " is a non-movement action!") (error "*dies*")
-            }
+              k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
-        Menu (Adjust (ActDown s) (Joystick _)) -> do
+          void $ liftIO $ swapMVar (translation ud) (JoyTranslation $
-          let k = fst <$> find (\(_, v) -> v == ActDown 1) (M.assocs tmap)
+            M.insert (AxisAction (fromIntegral axis) align) act $
-          putAffection ud
+              if isJust k then M.delete (fromJust k) tmap else tmap
-            { translation = JoyTranslation $
+            )
-              M.insert (AxisAction (fromIntegral axis) align) (ActDown 1) $
+          fullClean ud
-                if isJust k then M.delete (fromJust k) (tmap) else tmap
-            }
-        Menu (Adjust (ActLeft s) (Joystick _)) -> do
-          let k = fst <$> find (\(_, v) -> v == ActLeft 1) (M.assocs tmap)
-          putAffection ud
-            { translation = JoyTranslation $
-              M.insert (AxisAction (fromIntegral axis) align) (ActLeft 1) $
-                if isJust k then M.delete (fromJust k) (tmap) else tmap
-            }
-        Menu (Adjust (ActRight s) (Joystick _)) -> do
-          let k = fst <$> find (\(_, v) -> v == ActRight 1) (M.assocs tmap)
-          putAffection ud
-            { translation = JoyTranslation $
-              M.insert (AxisAction (fromIntegral axis) align) (ActRight 1) $
-                if isJust k then M.delete (fromJust k) (tmap) else tmap
-            }
-      fullClean
           switchBack
         _ -> return ()
-joyListener switchBack (MsgJoystickButton _ _ but SDL.JoyButtonPressed) = do
+    MsgJoystickButton _ _ but SDL.JoyButtonPressed -> do
-  ud <- getAffection
+      case trans of
-  case translation ud of
         JoyTranslation tmap -> do
-      case state ud of
+          case curState of
             Menu (Adjust (ActUp _) (Joystick _)) -> return ()
             Menu (Adjust (ActDown _) (Joystick _)) -> return ()
             Menu (Adjust (ActLeft _) (Joystick _)) -> return ()
             Menu (Adjust (ActRight _) (Joystick _)) -> return ()
             Menu (Adjust (act) (Joystick _)) -> do
               let k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
-          putAffection ud
+              void $ liftIO $ swapMVar (translation ud) (JoyTranslation $
-            { translation = JoyTranslation $
                 M.insert (ButtonAction but SDL.JoyButtonPressed) act $
                   if isJust k then M.delete (fromJust k) tmap else tmap
-            }
+                )
             _ -> return ()
-      fullClean
+          fullClean ud
           switchBack
-joyListener _ _ = return ()
+        x -> A.log A.Error (fromString (show x) <> " is a non-joystick translation!") (error "*dies*")
+    _ -> return ()
 
-drawAdjust :: Affection UserData ()
+drawAdjust :: Context -> Affection ()
-drawAdjust = do
+drawAdjust ctx = do
-  ud <- getAffection
   liftIO $ do
-    let ctx = nano ud
     save ctx
     beginPath ctx
     roundedRect ctx 440 310 400 100 10