retrofitting

src/Init.hs

@@ -46,7 +46,7 @@ init = do
     , uuid            = []
     , stateData       = None
     , threadContext   = Nothing
-    , joystick        = Nothing
+    , controls        = NoController
     , translation     = defaultTranslation
     , joyCache        = []
     }

src/Load.hs

@@ -73,12 +73,22 @@ loadFork ws win glc nvg future progress = do
   mcontrblue <- createImage nvg (FileName "assets/icons/controller_blue.png") 0
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
-    , "Loading icon \"conntroller_green\""
+    , "Loading icon \"controller_blue\""
     )))
   mcontrgreen <- createImage nvg (FileName "assets/icons/controller_green.png") 0
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
-    , "Loading icon \"arrow\""
+    , "Loading icon \"controller_green\""
+    )))
+  mcontrblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") 0
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading icon \"keyboard_blue\""
+    )))
+  mcontrgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") 0
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading icon \"keyboard_green\""
     )))
   marrow <- createImage nvg (FileName "assets/icons/arrow.png") 0
   modifyMVar_ progress (return . (\(p, _) ->

src/Menu/Connect.hs

@@ -31,7 +31,7 @@ loadMenu = do
   uu3 <- partSubscribe j emitJoyActionMessage
   uu4 <- partSubscribe t handleActionMessages
   uu5 <- partSubscribe m handleClicks
-  uu6 <- partSubscribe k emitKbdActionMessage
+  -- uu6 <- partSubscribe k emitKbdActionMessage
   partUnSubscribe j (joyUUID ud)
   putAffection ud
     { uuid      = [ uu1, uu2, uu3, uu4, uu5 ]
@@ -44,27 +44,28 @@ loadMenu = do
 joystickConnect :: JoystickMessage -> Affection UserData ()
 joystickConnect msg = do
   ud <- getAffection
-  when (isNothing $ joystick ud) $ do
+  when (controls ud == NoController) $ do
     mjoy <- joystickAutoConnect msg
     maybe (return ()) (\joy -> do
       ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy
       liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident
       putAffection ud
-        { controls = Joystick
+        { controls = Joystick joy
         }
       ) mjoy
 
 joystickDisconnect :: JoystickMessage -> Affection UserData ()
 joystickDisconnect msg = do
   ud <- getAffection
-  maybe (return ()) (\joy -> do
-    njoys <- joystickAutoDisconnect [joy] msg
-    when (null njoys) $ do
-      liftIO $ logIO A.Debug $ "Joystick disconnected"
-      putAffection ud
-        { Controls = None
-        }
-    ) (joystick ud)
+  case controls ud of
+    Joystick joy -> do
+      njoys <- joystickAutoDisconnect [joy] msg
+      when (null njoys) $ do
+        liftIO $ logIO A.Debug $ "Joystick disconnected"
+        putAffection ud
+          { controls = None
+          }
+    _ -> return ()
 
 handleActionMessages :: ActionMessage -> Affection UserData ()
 handleActionMessages (ActionMessage Activate _) = do
@@ -100,12 +101,16 @@ handleActionMessages (ActionMessage (LeftRight f) _) = do
 
 handleClicks :: MouseMessage -> Affection UserData ()
 handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
-  rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
-  when (arrowUp rels || arrowDown rels) (adjustUpDown rels)
-  when (arrowLeft rels || arrowRight rels) (adjustLeftRight rels)
-  when (buttonActivate rels) (adjustActivate)
-  when (buttonSwitchMap rels) (adjustSwitchMap)
-  when (buttonPlay rels) (enterGame)
+  ud <- getAffection
+  case controls ud of
+    Joystick -> do
+      rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
+      when (arrowUp rels || arrowDown rels) (adjustUpDown rels)
+      when (arrowLeft rels || arrowRight rels) (adjustLeftRight rels)
+      when (buttonActivate rels) (adjustActivate)
+      when (buttonSwitchMap rels) (adjustSwitchMap)
+      when (buttonPlay rels) (enterGame)
+    _ -> return ()
   where
     adjustUpDown rels = do
       if arrowUp rels
@@ -172,15 +177,26 @@ drawMenu = do
             controller = controls ud
         save ctx
         beginPath ctx
-        paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.!
-          if isNothing controller
-          then IconContrBlue
-          else IconContrGreen
+        cpaint <- imagePattern ctx 550 620 80 80 0 (assetIcons ud M.!
+          case controller of
+          Joystick -> IconContrGreen
+          _        -> IconContrBlue
           ) 1
         rect ctx 600 620 80 80
-        fillPaint ctx paint
+        fillPaint ctx cpaint
+        endPath ctx
         fill ctx
-        when (controller /= None) $ do
+        beginPath ctx
+        cpaint <- imagePattern ctx 650 620 80 80 0 (assetIcons ud M.!
+          case controller of
+          Keyboard -> IconKbdGreen
+          _        -> IconKbdBlue
+          ) 1
+        rect ctx 600 620 80 80
+        fillPaint ctx cpaint
+        endPath ctx
+        fill ctx
+        when (controller /= NoController) $ do
           let V2 vx vy = velocity $ stateData ud
           beginPath ctx
           roundedRect ctx 140 110 1000 500 25
@@ -264,9 +280,9 @@ drawMenu = do
                   _ ->
                     return ()
             beginPath ctx
-            paint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
+            apaint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
             rect ctx 0 0 100 100
-            fillPaint ctx paint
+            fillPaint ctx apaint
             closePath ctx
             fill ctx
             restore ctx

src/Types/ImgId.hs

@@ -3,6 +3,8 @@ module Types.ImgId where
 data IconId
   = IconContrBlue
   | IconContrGreen
+  | IconKbdBlue
+  | IconKbdGreen
   | IconArrow
   deriving (Show, Eq, Ord, Enum)
 

src/Types/UserData.hs

@@ -48,9 +48,9 @@ data UserData = UserData
   }
 
 data Controller
-  = None
+  = NoController
   | Keyboard
-  | Joystick
+  | Joystick SDL.Joystick
   deriving (Eq, Show)
 
 data State

src/Util.hs

@@ -304,8 +304,8 @@ cacheJoypad msg = do
     { joyCache = msg : joyCache ud
     }
 
-emitActionMessage :: JoystickMessage -> Affection UserData ()
-emitActionMessage (MsgJoystickAxis time _ axis val) = do
+emitJoyActionMessage :: JoystickMessage -> Affection UserData ()
+emitJoyActionMessage (MsgJoystickAxis time _ axis val) = do
   ud <- getAffection
   let Subsystems _ _ _ _ t = subsystems ud
   case (translation ud) Map.!? (AxisAction axis) of