ymonad-0.1.0.0: src/YMonad/Backend/River/Translate.hs

{-# LANGUAGE OverloadedStrings #-}

module YMonad.Backend.River.Translate (
  stageRequests,
  pumpPending,
) where

import Data.Map.Strict qualified as M

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

stageRequests :: RiverRuntime -> [BackendReq] -> RiverRuntime
stageRequests = foldl' stageRequest

stageRequest :: RiverRuntime -> BackendReq -> RiverRuntime
stageRequest rt req = case req of
  ReqShowView vid -> enqueueRender rt vid (\handle -> [mkWindowRequest rt handle "show" []])
  ReqHideView vid -> enqueueRender rt vid (\handle -> [mkWindowRequest rt handle "hide" []])
  ReqSetViewRect vid rect -> enqueueRender (enqueueManage rt vid manageMessages) vid renderMessages
    where
      manageMessages handle = [mkWindowRequest rt handle "propose_dimensions" [ArgIntValue (fromIntegral (rectWidth rect)), ArgIntValue (fromIntegral (rectHeight rect))]]
      renderMessages handle =
        [ mkNodeRequest rt handle "set_position" [ArgIntValue (fromIntegral (rectX rect)), ArgIntValue (fromIntegral (rectY rect))]
        , mkWindowRequest rt handle "show" []
        ]
  ReqSetViewStyle vid style -> enqueueRender (enqueueManage rt vid manageMessages) vid renderMessages
    where
      manageMessages handle =
        [ mkWindowRequest rt handle (case viewStyleTitleBarMode style of NoTitleBar -> "use_ssd"; ServerSideTitleBar -> "use_ssd") []
        ]
      renderMessages handle = [mkSetBordersRequest rt handle style]
  ReqFocusView Nothing -> case rrSeat rt of
    Nothing -> rt
    Just seat -> rt {rrPendingManage = rrPendingManage rt ++ [mkSeatRequest rt seat "clear_focus" []]}
  ReqFocusView (Just vid) ->
    enqueueManage
      rt
      vid
      ( \handle -> case rrSeat rt of
          Nothing -> []
          Just seat -> [mkSeatFocusWindow rt seat handle]
      )
  ReqCloseView vid -> enqueueManage rt vid (\handle -> [mkWindowRequest rt handle "close" []])
  ReqExitSession -> case rrManagerObject rt of
    Nothing -> rt
    Just managerId -> rt {rrOutgoing = rrOutgoing rt ++ [managerRequest rt managerId "exit_session" []]}
  ReqCommit -> rt

enqueueManage :: RiverRuntime -> ViewId -> (RiverViewHandle -> [WireMessage]) -> RiverRuntime
enqueueManage rt vid f = case M.lookup vid (rrViews rt) of
  Nothing -> rt
  Just handle -> rt {rrPendingManage = rrPendingManage rt ++ f handle}

enqueueRender :: RiverRuntime -> ViewId -> (RiverViewHandle -> [WireMessage]) -> RiverRuntime
enqueueRender rt vid f = case M.lookup vid (rrViews rt) of
  Nothing -> rt
  Just handle -> rt {rrPendingRender = rrPendingRender rt ++ f handle}

pumpPending :: RiverRuntime -> RiverRuntime
pumpPending rt = pumpRender (pumpManage rt)

pumpManage :: RiverRuntime -> RiverRuntime
pumpManage rt = case rrPhase rt of
  RiverPhaseManage ->
    let finish = maybe [] (\managerId -> [managerRequest rt managerId "manage_finish" []]) (rrManagerObject rt)
     in rt
          { rrOutgoing = rrOutgoing rt ++ rrPendingManage rt ++ finish
          , rrPendingManage = []
          , rrManageDirtySent = False
          , rrPhase = RiverPhaseIdle
          }
  _otherPhase
    | null (rrPendingManage rt) -> requestManageIfNeeded rt
    | otherwise -> requestManageIfNeeded rt

pumpRender :: RiverRuntime -> RiverRuntime
pumpRender rt = case rrPhase rt of
  RiverPhaseRender ->
    let finish = maybe [] (\managerId -> [managerRequest rt managerId "render_finish" []]) (rrManagerObject rt)
     in rt
          { rrOutgoing = rrOutgoing rt ++ rrPendingRender rt ++ finish
          , rrPendingRender = []
          , rrPhase = RiverPhaseIdle
          }
  _otherPhase -> rt

requestManageIfNeeded :: RiverRuntime -> RiverRuntime
requestManageIfNeeded rt
  | null (rrPendingManage rt) = rt
  | rrManageDirtySent rt = rt
  | otherwise = case rrManagerObject rt of
      Nothing -> rt
      Just managerId ->
        rt
          { rrOutgoing = rrOutgoing rt ++ [managerRequest rt managerId "manage_dirty" []]
          , rrManageDirtySent = True
          }

managerRequest :: RiverRuntime -> Word32 -> Text -> [ArgValue] -> WireMessage
managerRequest rt managerId name args =
  WireMessage
    { wireObjectId = managerId
    , wireInterface = "river_window_manager_v1"
    , wireMessageName = name
    , wireOpcode = requestOpcode rt "river_window_manager_v1" name
    , wireArgs = args
    }

mkWindowRequest :: RiverRuntime -> RiverViewHandle -> Text -> [ArgValue] -> WireMessage
mkWindowRequest rt handle name args =
  WireMessage
    { wireObjectId = riverWindowObjectId handle
    , wireInterface = "river_window_v1"
    , wireMessageName = name
    , wireOpcode = requestOpcode rt "river_window_v1" name
    , wireArgs = args
    }

mkNodeRequest :: RiverRuntime -> RiverViewHandle -> Text -> [ArgValue] -> WireMessage
mkNodeRequest rt handle name args =
  WireMessage
    { wireObjectId = fromMaybe 0 (riverNodeObjectId handle)
    , wireInterface = "river_node_v1"
    , wireMessageName = name
    , wireOpcode = requestOpcode rt "river_node_v1" name
    , wireArgs = args
    }

mkSeatRequest :: RiverRuntime -> RiverSeatHandle -> Text -> [ArgValue] -> WireMessage
mkSeatRequest rt seat name args =
  WireMessage
    { wireObjectId = riverSeatObjectId seat
    , wireInterface = "river_seat_v1"
    , wireMessageName = name
    , wireOpcode = requestOpcode rt "river_seat_v1" name
    , wireArgs = args
    }

mkSeatFocusWindow :: RiverRuntime -> RiverSeatHandle -> RiverViewHandle -> WireMessage
mkSeatFocusWindow rt seat handle = mkSeatRequest rt seat "focus_window" [ArgObjectValue (Just (riverWindowObjectId handle))]

mkSetBordersRequest :: RiverRuntime -> RiverViewHandle -> ViewStyle -> WireMessage
mkSetBordersRequest rt handle style =
  mkWindowRequest
    rt
    handle
    "set_borders"
    [ ArgUintValue edges
    , ArgIntValue (fromIntegral width)
    , ArgUintValue (rgbaRed color)
    , ArgUintValue (rgbaGreen color)
    , ArgUintValue (rgbaBlue color)
    , ArgUintValue (rgbaAlpha color)
    ]
  where
    width = max 0 (unDimension (viewStyleBorderWidth style))
    edges = if width > 0 then allEdges else 0
    color = viewStyleBorderColor style

allEdges :: Word32
allEdges = 1 + 2 + 4 + 8

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