Send keypresses when a text input is submitted (Linux only)

haskell/linux/OS.hs

@@ -1,10 +1,11 @@
 module OS (conf, keyUnknown) where
 
 import Control.Monad.Reader
-import Control.Monad.State
 import Data.Either
 import Data.Foldable
 import Data.Int
+import Data.List.Extra hiding (insert, (!?))
+import Data.Maybe
 import Data.Traversable
 import Optics hiding (Empty)
 
@@ -13,6 +14,8 @@ import Data.Coerce (coerce)
 import Data.List.NonEmpty qualified as NE
 import Data.Map (Map, (!?))
 import Data.Map qualified as Map
+import Data.Text (Text)
+import Data.Text qualified as T
 import Data.Text.Encoding (encodeUtf8)
 import Dhall (FromDhall)
 import GHC.Generics (Generic)
@@ -27,7 +30,7 @@ import Monpad
 import Orphans.Evdev ()
 
 type E = Map LayoutID (Device, LayoutMeta)
-type S = (Device, LayoutMeta)
+type S = ((Device, LayoutMeta), Text)
 type A = AxisInfo
 type B = Key
 
@@ -36,7 +39,13 @@ conf = ServerConfig
     { onNewConnection = \(fmap fst -> layouts) (ClientID clientId) -> do
         layoutInfos <- for layouts \layout -> do
             let meta = mkLayoutMeta $ layout ^. #elements
-                (axes, keys) = allAxesAndButs meta
+                (axes, keys0) = allAxesAndButs meta
+                isTextInput = \case
+                    FullElement{element = Input Input'{inputType = Text _}} -> True
+                    _ -> False
+                keys = if any isTextInput $ layout ^. #elements
+                    then keys0 <> filter (isJust . keyToChar) enumerate
+                    else keys0
                 (absAxes, relAxes) = partitionEithers $ axes <&> \case
                     AxisInfo{axis = Abs a, ..} -> Left
                         ( a
@@ -69,14 +78,14 @@ conf = ServerConfig
                 )
         pure
             ( Map.fromList $ toList layoutInfos
-            , snd $ NE.head layoutInfos
+            , (snd $ NE.head layoutInfos, "")
             , []
             )
     , onUpdate = \case
         ServerUpdate (SwitchLayout l) -> do
             ls <- asks (^. #extra)
             case ls !? l of
-                Just x -> #extra .= x
+                Just x -> #extra % _1 .= x
                 Nothing -> warn $ "no evdev device found for layout: " <> coerce l
             mempty
         ClientUpdate (ButtonUp i) ->
@@ -87,6 +96,18 @@ conf = ServerConfig
             lookup' #stickMap i \(x', y') -> onAxis x x' <> onAxis y y'
         ClientUpdate (SliderMove i x) ->
             lookup' #sliderMap i . onAxis $ x * 2 - 1
+        ClientUpdate (InputText _ t) -> do
+            (#extra % _2) .= t
+            mempty
+        ClientUpdate (SubmitInput _) -> do
+            dev <- use $ #extra % _1 % _1
+            liftIO . writeBatch dev
+                . concatMap (\k -> [KeyEvent k Pressed, KeyEvent k Released])
+                . (++ [KeyEnter])
+                . mapMaybe charToKey
+                . T.unpack
+                =<< use (#extra % _2)
+            mempty
         _ -> mempty
     , onStart = mempty
     , onDroppedConnection = mempty
@@ -101,7 +122,7 @@ conf = ServerConfig
         (a -> Device -> Monpad E S A B ()) ->
         Monpad E S A B m
     lookup' l i f = do
-        (device, info) <- gets (^. #extra)
+        (device, info) <- use $ #extra % _1
         case (info ^. l) !? i of
             Just a -> f a device
             Nothing -> warn $ "element id not found: " <> coerce i
@@ -159,3 +180,107 @@ data Axis
 
 keyUnknown :: Key
 keyUnknown = KeyUnknown
+
+charToKey :: Char -> Maybe Key
+charToKey = \case
+    '0' -> Just Key0
+    '1' -> Just Key1
+    '2' -> Just Key2
+    '3' -> Just Key3
+    '4' -> Just Key4
+    '5' -> Just Key5
+    '6' -> Just Key6
+    '7' -> Just Key7
+    '8' -> Just Key8
+    '9' -> Just Key9
+    'a' -> Just KeyA
+    'b' -> Just KeyB
+    'c' -> Just KeyC
+    'd' -> Just KeyD
+    'e' -> Just KeyE
+    'f' -> Just KeyF
+    'g' -> Just KeyG
+    'h' -> Just KeyH
+    'i' -> Just KeyI
+    'j' -> Just KeyJ
+    'k' -> Just KeyK
+    'l' -> Just KeyL
+    'm' -> Just KeyM
+    'n' -> Just KeyN
+    'o' -> Just KeyO
+    'p' -> Just KeyP
+    'q' -> Just KeyQ
+    'r' -> Just KeyR
+    's' -> Just KeyS
+    't' -> Just KeyT
+    'u' -> Just KeyU
+    'v' -> Just KeyV
+    'w' -> Just KeyW
+    'x' -> Just KeyX
+    'y' -> Just KeyY
+    'z' -> Just KeyZ
+    '\'' -> Just KeyApostrophe
+    '\\' -> Just KeyBackslash
+    ',' -> Just KeyComma
+    '.' -> Just KeyDot
+    '=' -> Just KeyEqual
+    '`' -> Just KeyGrave
+    '{' -> Just KeyLeftbrace
+    '-' -> Just KeyMinus
+    '}' -> Just KeyRightbrace
+    ';' -> Just KeySemicolon
+    '/' -> Just KeySlash
+    ' ' -> Just KeySpace
+    _ -> Nothing
+
+keyToChar :: Key -> Maybe Char
+keyToChar = \case
+    Key0 ->  Just '0'
+    Key1 ->  Just '1'
+    Key2 ->  Just '2'
+    Key3 ->  Just '3'
+    Key4 ->  Just '4'
+    Key5 ->  Just '5'
+    Key6 ->  Just '6'
+    Key7 ->  Just '7'
+    Key8 ->  Just '8'
+    Key9 ->  Just '9'
+    KeyA ->  Just 'a'
+    KeyB ->  Just 'b'
+    KeyC ->  Just 'c'
+    KeyD ->  Just 'd'
+    KeyE ->  Just 'e'
+    KeyF ->  Just 'f'
+    KeyG ->  Just 'g'
+    KeyH ->  Just 'h'
+    KeyI ->  Just 'i'
+    KeyJ ->  Just 'j'
+    KeyK ->  Just 'k'
+    KeyL ->  Just 'l'
+    KeyM ->  Just 'm'
+    KeyN ->  Just 'n'
+    KeyO ->  Just 'o'
+    KeyP ->  Just 'p'
+    KeyQ ->  Just 'q'
+    KeyR ->  Just 'r'
+    KeyS ->  Just 's'
+    KeyT ->  Just 't'
+    KeyU ->  Just 'u'
+    KeyV ->  Just 'v'
+    KeyW ->  Just 'w'
+    KeyX ->  Just 'x'
+    KeyY ->  Just 'y'
+    KeyZ ->  Just 'z'
+    KeyApostrophe ->  Just '\''
+    KeyBackslash ->  Just '\\'
+    KeyComma ->  Just ','
+    KeyDot ->  Just '.'
+    KeyEqual ->  Just '='
+    KeyGrave ->  Just '`'
+    KeyLeftbrace ->  Just '{'
+    KeyMinus ->  Just '-'
+    KeyRightbrace ->  Just '}'
+    KeySemicolon ->  Just ';'
+    KeySlash ->  Just '/'
+    KeySpace ->  Just ' '
+    _ -> Nothing