Decode.hs

{-# LANGUAGE OverloadedStrings #-}

module YMonad.Backend.River.Decode (
  decodeCallback,
  ingestBytes,
) where

import Data.ByteString qualified as BS
import Data.Map.Strict qualified as M
import Data.Text qualified as T

import YMonad.Backend.River.Types
import YMonad.Core
import YMonad.Protocol.Wayland.Types
import YMonad.Protocol.Wayland.Wire

decodeCallback :: RiverCallback -> Either BackendFault [YEvent]
decodeCallback cb = Right $ case cb of
  RiverViewCreated vid meta -> [EvViewMapped vid meta]
  RiverViewDestroyed vid -> [EvViewUnmapped vid]
  RiverOutputDiscovered oid info -> [EvOutputAdded oid info]
  RiverOutputLost oid -> [EvOutputRemoved oid]
  RiverSeatFocus mvid -> [EvFocusChanged mvid]
  RiverManageStart -> []
  RiverRenderStart -> []
  RiverUserCommand cmd -> [EvUserCommand cmd]
  RiverActionTriggered _ -> []
  RiverProtocolFault msg -> [EvBackendFault (BackendFault msg)]
  RiverTrace _msg -> []

ingestBytes :: RiverRuntime -> BS.ByteString -> Either BackendFault (RiverRuntime, [RiverCallback])
ingestBytes rt chunk = do
  let buffered = rrInboundBuffer rt <> chunk
  (frames, leftover) <- firstFault (decodeRawFrames buffered)
  processFrames (rt {rrInboundBuffer = leftover}) id frames
  where
    processFrames runtime callbacks [] = Right (runtime, callbacks [])
    processFrames runtime callbacks (frame : rest) = do
      (runtime', produced) <- processFrame runtime frame
      processFrames runtime' (callbacks . (produced ++)) rest

processFrame :: RiverRuntime -> RawFrame -> Either BackendFault (RiverRuntime, [RiverCallback])
processFrame rt frame = do
  ifaceName <- case M.lookup (rawObjectId frame) (rrObjectInterfaces rt) of
    Nothing -> Left (BackendFault ("Unknown Wayland object id: " <> tshow (rawObjectId frame)))
    Just name -> Right name
  spec <- case lookupEventByOpcode (rrProtocol rt) ifaceName (rawOpcode frame) of
    Nothing -> Left (BackendFault ("Unknown event opcode " <> tshow (rawOpcode frame) <> " for interface " <> ifaceName))
    Just found -> Right found
  args <- firstFault (decodeMessageArgs spec (rawPayload frame))
  interpretEvent rt frame ifaceName spec args

interpretEvent :: RiverRuntime -> RawFrame -> Text -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
interpretEvent rt frame ifaceName spec args
  | ifaceName == "wl_registry" && messageSpecName spec == "global" = handleRegistryGlobal rt args
  | ifaceName == "wl_display" && messageSpecName spec == "error" =
      Right (rt, [RiverProtocolFault ("wl_display.error: " <> T.intercalate ", " (map renderArg args))])
  | ifaceName == "wl_callback" = handleCallbackEvent rt (rawObjectId frame) spec args
  | ifaceName == "river_window_manager_v1" = handleManagerEvent rt spec args
  | ifaceName == "river_xkb_binding_v1" = handleXkbBindingEvent rt (rawObjectId frame) spec args
  | ifaceName == "river_window_v1" = handleWindowEvent rt (rawObjectId frame) spec args
  | ifaceName == "river_output_v1" = handleOutputEvent rt (rawObjectId frame) spec args
  | ifaceName == "river_seat_v1" = handleSeatEvent rt spec args
  | otherwise = Right (rt, [])

handleRegistryGlobal :: RiverRuntime -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
handleRegistryGlobal rt [ArgUintValue globalName, ArgStringValue (Just ifaceName), ArgUintValue version]
  | ifaceName == "river_window_manager_v1" =
      case rrManagerObject rt of
        Just _ -> Right (rt, [])
        Nothing ->
          let (managerId, rt1) = allocateObjectId rt
              bindMessage =
                WireMessage
                  { wireObjectId = rrRegistryObject rt1
                  , wireInterface = "wl_registry"
                  , wireMessageName = "bind"
                  , wireOpcode = 0
                  , wireArgs =
                      [ ArgUintValue globalName
                      , ArgStringValue (Just ifaceName)
                      , ArgUintValue version
                      , ArgNewIdValue managerId
                      ]
                  }
              rt2 =
                rt1
                  { rrManagerObject = Just managerId
                  , rrObjectInterfaces = M.insert managerId ifaceName (rrObjectInterfaces rt1)
                  , rrOutgoing = rrOutgoing rt1 ++ [bindMessage]
                  }
           in Right (rt2, [RiverTrace ("bound river_window_manager_v1 object " <> tshow managerId)])
  | ifaceName == "river_xkb_bindings_v1" =
      case rrXkbBindingsObject rt of
        Just _ -> Right (rt, [])
        Nothing ->
          let (bindingsId, rt1) = allocateObjectId rt
              bindMessage =
                WireMessage
                  { wireObjectId = rrRegistryObject rt1
                  , wireInterface = "wl_registry"
                  , wireMessageName = "bind"
                  , wireOpcode = 0
                  , wireArgs =
                      [ ArgUintValue globalName
                      , ArgStringValue (Just ifaceName)
                      , ArgUintValue version
                      , ArgNewIdValue bindingsId
                      ]
                  }
              rt2 =
                rt1
                  { rrXkbBindingsObject = Just bindingsId
                  , rrObjectInterfaces = M.insert bindingsId ifaceName (rrObjectInterfaces rt1)
                  , rrOutgoing = rrOutgoing rt1 ++ [bindMessage]
                  }
           in Right (rt2, [RiverTrace ("bound river_xkb_bindings_v1 object " <> tshow bindingsId)])
  | otherwise = Right (rt, [])
handleRegistryGlobal _ _ = Left (BackendFault "Malformed wl_registry.global payload")

handleCallbackEvent :: RiverRuntime -> Word32 -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
handleCallbackEvent rt objectId spec args = case messageSpecName spec of
  "done" -> case args of
    [ArgUintValue _callbackData]
      | Just objectId == rrStartupSyncObject rt ->
          let rt' =
                rt
                  { rrStartupSyncObject = Nothing
                  , rrRegistryReady = True
                  , rrObjectInterfaces = M.delete objectId (rrObjectInterfaces rt)
                  }
           in Right (rt', [RiverTrace "registry roundtrip complete"])
    [ArgUintValue _callbackData] -> Right (rt, [])
    unexpectedDoneArgs -> Left (BackendFault ("Malformed wl_callback.done payload: " <> tshow unexpectedDoneArgs))
  _otherCallbackEvent -> Right (rt, [])

handleManagerEvent :: RiverRuntime -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
handleManagerEvent rt spec args = case messageSpecName spec of
  "manage_start" -> Right (rt {rrPhase = RiverPhaseManage, rrManageDirtySent = False}, [RiverTrace "manage_start", RiverManageStart])
  "render_start" -> Right (rt {rrPhase = RiverPhaseRender}, [RiverTrace "render_start", RiverRenderStart])
  "window" -> case args of
    [ArgNewIdValue windowId] ->
      let vid = ViewId (fromIntegral windowId)
          (nodeId, rt1) = allocateObjectId rt
          getNode =
            WireMessage
              { wireObjectId = windowId
              , wireInterface = "river_window_v1"
              , wireMessageName = "get_node"
              , wireOpcode = opcodeOf rt1 "river_window_v1" "get_node"
              , wireArgs = [ArgNewIdValue nodeId]
              }
          handle = RiverViewHandle windowId (Just nodeId) "" "" Nothing
          rt2 =
            rt1
              { rrViews = M.insert vid handle (rrViews rt1)
              , rrViewsByObjectId = M.insert windowId vid (rrViewsByObjectId rt1)
              , rrObjectInterfaces = M.insert nodeId "river_node_v1" (M.insert windowId "river_window_v1" (rrObjectInterfaces rt1))
              , rrOutgoing = rrOutgoing rt1 ++ [getNode]
              }
          meta = ViewMeta "" "" False
       in Right (rt2, [RiverTrace ("manager announced window " <> tshow (unViewId vid) <> " (object " <> tshow windowId <> ")"), RiverViewCreated vid meta])
    unexpectedWindowArgs -> Left (BackendFault ("Malformed river_window_manager_v1.window payload: " <> tshow unexpectedWindowArgs))
  "output" -> case args of
    [ArgNewIdValue outputObj] ->
      let oid = OutputId (fromIntegral outputObj)
          handle = RiverOutputHandle outputObj Nothing Nothing
          rt' =
            rt
              { rrOutputs = M.insert oid handle (rrOutputs rt)
              , rrOutputsByObjectId = M.insert outputObj oid (rrOutputsByObjectId rt)
              , rrObjectInterfaces = M.insert outputObj "river_output_v1" (rrObjectInterfaces rt)
              }
       in Right (rt', [])
    unexpectedOutputArgs -> Left (BackendFault ("Malformed river_window_manager_v1.output payload: " <> tshow unexpectedOutputArgs))
  "seat" -> case args of
    [ArgNewIdValue seatObj] ->
      let seat = RiverSeatHandle seatObj
          rt' =
            rt
              { rrSeat = Just seat
              , rrObjectInterfaces = M.insert seatObj "river_seat_v1" (rrObjectInterfaces rt)
              }
       in Right (rt', [RiverTrace ("seat discovered: object " <> tshow seatObj)])
    unexpectedSeatArgs -> Left (BackendFault ("Malformed river_window_manager_v1.seat payload: " <> tshow unexpectedSeatArgs))
  "unavailable" -> Right (rt, [RiverProtocolFault "river window management unavailable"])
  _otherManagerEvent -> Right (rt, [])

handleXkbBindingEvent :: RiverRuntime -> Word32 -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
handleXkbBindingEvent rt objectId spec _args =
  case bindingActionForObject rt objectId of
    Nothing -> Right (rt, [])
    Just action -> case messageSpecName spec of
      "pressed" -> Right (rt, [RiverActionTriggered action])
      "released" -> Right (rt, [])
      "stop_repeat" -> Right (rt, [])
      _otherBindingEvent -> Right (rt, [])

handleWindowEvent :: RiverRuntime -> Word32 -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
handleWindowEvent rt objectId spec args = case M.lookup objectId (rrViewsByObjectId rt) of
  Nothing -> Right (rt, [])
  Just vid -> case messageSpecName spec of
    "closed" ->
      let rt' =
            rt
              { rrViews = M.delete vid (rrViews rt)
              , rrViewsByObjectId = M.delete objectId (rrViewsByObjectId rt)
              }
       in Right (rt', [RiverViewDestroyed vid])
    "title" -> case args of
      [ArgStringValue maybeTitle] ->
        let title = fromMaybe "" maybeTitle
         in Right (updateViewMeta rt vid (\h -> h {riverViewTitle = title}), [])
      unexpectedTitleArgs -> Left (BackendFault ("Malformed river_window_v1.title payload: " <> tshow unexpectedTitleArgs))
    "app_id" -> case args of
      [ArgStringValue maybeAppId] ->
        let appId = fromMaybe "" maybeAppId
         in Right (updateViewMeta rt vid (\h -> h {riverViewAppId = appId}), [])
      unexpectedAppIdArgs -> Left (BackendFault ("Malformed river_window_v1.app_id payload: " <> tshow unexpectedAppIdArgs))
    "dimensions" -> case args of
      [ArgIntValue w, ArgIntValue h] ->
        let size = Size (fromIntegral w) (fromIntegral h)
            rt' = updateViewMeta rt vid (\hnd -> hnd {riverViewDimensions = Just size})
         in Right (rt', [RiverTrace ("window " <> tshow (unViewId vid) <> " dimensions " <> tshow w <> "x" <> tshow h)])
      unexpectedDimensionsArgs -> Left (BackendFault ("Malformed river_window_v1.dimensions payload: " <> tshow unexpectedDimensionsArgs))
    _otherWindowEvent -> Right (rt, [])

handleOutputEvent :: RiverRuntime -> Word32 -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
handleOutputEvent rt objectId spec args = case M.lookup objectId (rrOutputsByObjectId rt) of
  Nothing -> Right (rt, [])
  Just oid -> case messageSpecName spec of
    "removed" ->
      let rt' =
            rt
              { rrOutputs = M.delete oid (rrOutputs rt)
              , rrOutputsByObjectId = M.delete objectId (rrOutputsByObjectId rt)
              }
       in Right (rt', [RiverOutputLost oid])
    "position" -> case args of
      [ArgIntValue x, ArgIntValue y] ->
        emitOutput rt oid (\h -> h {riverOutputPosition = Just (Point (fromIntegral x) (fromIntegral y))})
      unexpectedPositionArgs -> Left (BackendFault ("Malformed river_output_v1.position payload: " <> tshow unexpectedPositionArgs))
    "dimensions" -> case args of
      [ArgIntValue w, ArgIntValue h] ->
        emitOutput rt oid (\handle -> handle {riverOutputSize = Just (Size (fromIntegral w) (fromIntegral h))})
      unexpectedDimensionsArgs -> Left (BackendFault ("Malformed river_output_v1.dimensions payload: " <> tshow unexpectedDimensionsArgs))
    _otherOutputEvent -> Right (rt, [])

handleSeatEvent :: RiverRuntime -> MessageSpec -> [ArgValue] -> Either BackendFault (RiverRuntime, [RiverCallback])
handleSeatEvent rt spec args = case messageSpecName spec of
  "pointer_enter" -> Right (rt, [])
  "window_interaction" -> case args of
    [ArgObjectValue (Just windowObj)] ->
      let mVid = M.lookup windowObj (rrViewsByObjectId rt)
       in Right (rt, [RiverSeatFocus mVid])
    _unexpectedWindowInteractionArgs -> Right (rt, [])
  _otherSeatEvent -> Right (rt, [])

emitOutput :: RiverRuntime -> OutputId -> (RiverOutputHandle -> RiverOutputHandle) -> Either BackendFault (RiverRuntime, [RiverCallback])
emitOutput rt oid f = case M.lookup oid (rrOutputs rt) of
  Nothing -> Right (rt, [])
  Just handle ->
    let updated = f handle
        rt' = rt {rrOutputs = M.insert oid updated (rrOutputs rt)}
     in case (riverOutputPosition updated, riverOutputSize updated) of
          (Just point, Just size) ->
            let info =
                  OutputInfo
                    { outputName = "river-output-" <> tshow (unOutputId oid)
                    , outputRect = Rect (pointX point) (pointY point) (sizeWidth size) (sizeHeight size)
                    }
             in Right (rt', [RiverOutputDiscovered oid info])
          _incompleteOutputInfo -> Right (rt', [])

updateViewMeta :: RiverRuntime -> ViewId -> (RiverViewHandle -> RiverViewHandle) -> RiverRuntime
updateViewMeta rt vid f = case M.lookup vid (rrViews rt) of
  Nothing -> rt
  Just handle -> rt {rrViews = M.insert vid (f handle) (rrViews rt)}

opcodeOf :: RiverRuntime -> Text -> Text -> Word16
opcodeOf rt ifaceName msgName =
  maybe
    0
    messageSpecOpcode
    (lookupRequest (rrProtocol rt) ifaceName msgName)

firstFault :: Either String a -> Either BackendFault a
firstFault = either (Left . BackendFault . T.pack) Right

renderArg :: ArgValue -> Text
renderArg arg = case arg of
  ArgIntValue n -> tshow n
  ArgUintValue n -> tshow n
  ArgStringValue Nothing -> "<null>"
  ArgStringValue (Just txt) -> txt
  ArgObjectValue Nothing -> "object:null"
  ArgObjectValue (Just oid) -> "object:" <> tshow oid
  ArgNewIdValue oid -> "new_id:" <> tshow oid

tshow :: (Show a) => a -> Text
tshow = T.pack . show