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

{-# LANGUAGE OverloadedStrings #-}

module YMonad.Backend.River.Types (
  RiverViewHandle (..),
  RiverOutputHandle (..),
  RiverSeatHandle (..),
  RiverPhase (..),
  RiverCallback (..),
  RiverConnection (..),
  RiverRuntime (..),
  bindingActionForObject,
  loadRiverRuntime,
  emptyRiverRuntime,
  allocateObjectId,
) where

import Data.ByteString qualified as BS
import Data.Map.Strict qualified as M
import Paths_ymonad (getDataFileName)

import YMonad.Config (YAction)
import YMonad.Core
import YMonad.Protocol.Wayland.Types
import YMonad.Protocol.Wayland.Xml

data RiverViewHandle = RiverViewHandle
  { riverWindowObjectId :: Word32
  , riverNodeObjectId :: Maybe Word32
  , riverViewTitle :: Text
  , riverViewAppId :: Text
  , riverViewDimensions :: Maybe Size
  }
  deriving stock (Eq, Ord, Show)

data RiverOutputHandle = RiverOutputHandle
  { riverOutputObjectId :: Word32
  , riverOutputPosition :: Maybe Point
  , riverOutputSize :: Maybe Size
  }
  deriving stock (Eq, Ord, Show)

newtype RiverSeatHandle = RiverSeatHandle
  { riverSeatObjectId :: Word32
  }
  deriving stock (Eq, Ord, Show)

data RiverPhase
  = RiverPhaseIdle
  | RiverPhaseManage
  | RiverPhaseRender
  deriving stock (Eq, Ord, Show)

data RiverCallback
  = RiverViewCreated ViewId ViewMeta
  | RiverViewDestroyed ViewId
  | RiverOutputDiscovered OutputId OutputInfo
  | RiverOutputLost OutputId
  | RiverSeatFocus (Maybe ViewId)
  | RiverManageStart
  | RiverRenderStart
  | RiverUserCommand UserCommand
  | RiverActionTriggered YAction
  | RiverProtocolFault Text
  | RiverTrace Text
  deriving stock (Eq, Ord, Show)

newtype RiverConnection = RiverConnection
  { riverSocketPath :: FilePath
  }
  deriving stock (Eq, Ord, Show)

data RiverRuntime = RiverRuntime
  { rrProtocol :: ProtocolSpec
  , rrDisplayObject :: Word32
  , rrRegistryObject :: Word32
  , rrManagerObject :: Maybe Word32
  , rrXkbBindingsObject :: Maybe Word32
  , rrStartupSyncObject :: Maybe Word32
  , rrRegistryReady :: Bool
  , rrSeat :: Maybe RiverSeatHandle
  , rrBindingActions :: Map Word32 YAction
  , rrBindingsInstalled :: Bool
  , rrViews :: Map ViewId RiverViewHandle
  , rrViewsByObjectId :: Map Word32 ViewId
  , rrOutputs :: Map OutputId RiverOutputHandle
  , rrOutputsByObjectId :: Map Word32 OutputId
  , rrObjectInterfaces :: Map Word32 Text
  , rrPendingManage :: [WireMessage]
  , rrPendingRender :: [WireMessage]
  , rrOutgoing :: [WireMessage]
  , rrInboundBuffer :: BS.ByteString
  , rrNextObjectId :: Word32
  , rrPhase :: RiverPhase
  , rrManageDirtySent :: Bool
  }
  deriving stock (Eq, Show)

loadRiverRuntime :: IO (Either String RiverRuntime)
loadRiverRuntime = do
  windowPath <- getDataFileName "protocol/river/river-window-management-v1.xml"
  xkbPath <- getDataFileName "protocol/river/river-xkb-bindings-v1.xml"
  windowSpecResult <- loadProtocolSpec windowPath
  xkbSpecResult <- loadProtocolSpec xkbPath
  pure $ do
    windowSpec <- windowSpecResult
    emptyRiverRuntime . mergeProtocolSpecs windowSpec <$> xkbSpecResult

emptyRiverRuntime :: ProtocolSpec -> RiverRuntime
emptyRiverRuntime riverSpec =
  let base = baseProtocolSpec
      merged = mergeProtocolSpecs base riverSpec
      registryMessage = bootstrapGetRegistry
   in RiverRuntime
        { rrProtocol = merged
        , rrDisplayObject = 1
        , rrRegistryObject = 2
        , rrManagerObject = Nothing
        , rrXkbBindingsObject = Nothing
        , rrStartupSyncObject = Just 3
        , rrRegistryReady = False
        , rrSeat = Nothing
        , rrBindingActions = M.empty
        , rrBindingsInstalled = False
        , rrViews = M.empty
        , rrViewsByObjectId = M.empty
        , rrOutputs = M.empty
        , rrOutputsByObjectId = M.empty
        , rrObjectInterfaces = M.fromList [(1, "wl_display"), (2, "wl_registry"), (3, "wl_callback")]
        , rrPendingManage = []
        , rrPendingRender = []
        , rrOutgoing = [registryMessage, bootstrapSync 3]
        , rrInboundBuffer = BS.empty
        , rrNextObjectId = 4
        , rrPhase = RiverPhaseIdle
        , rrManageDirtySent = False
        }

allocateObjectId :: RiverRuntime -> (Word32, RiverRuntime)
allocateObjectId rt = (rrNextObjectId rt, rt {rrNextObjectId = rrNextObjectId rt + 1})

baseProtocolSpec :: ProtocolSpec
baseProtocolSpec =
  ProtocolSpec
    { protocolName = "wayland-core"
    , protocolInterfaces =
        M.fromList
          [ (interfaceName wlDisplay, wlDisplay)
          , (interfaceName wlRegistry, wlRegistry)
          , (interfaceName wlCallback, wlCallback)
          ]
    }
  where
    wlDisplay =
      mkInterfaceSpec
        "wl_display"
        1
        [ MessageSpec "sync" 0 MessageRequest [ArgSpec "callback" (ArgNewId (Just "wl_callback")) False]
        , MessageSpec "get_registry" 1 MessageRequest [ArgSpec "registry" (ArgNewId (Just "wl_registry")) False]
        ]
        [ MessageSpec
            "error"
            0
            MessageEvent
            [ ArgSpec "object_id" (ArgObject Nothing) False
            , ArgSpec "code" ArgUint False
            , ArgSpec "message" ArgString False
            ]
        , MessageSpec "delete_id" 1 MessageEvent [ArgSpec "id" ArgUint False]
        ]
    wlRegistry =
      mkInterfaceSpec
        "wl_registry"
        1
        [ MessageSpec
            "bind"
            0
            MessageRequest
            [ ArgSpec "name" ArgUint False
            , ArgSpec "interface" ArgString False
            , ArgSpec "version" ArgUint False
            , ArgSpec "id" (ArgNewId Nothing) False
            ]
        ]
        [ MessageSpec
            "global"
            0
            MessageEvent
            [ ArgSpec "name" ArgUint False
            , ArgSpec "interface" ArgString False
            , ArgSpec "version" ArgUint False
            ]
        , MessageSpec "global_remove" 1 MessageEvent [ArgSpec "name" ArgUint False]
        ]
    wlCallback =
      mkInterfaceSpec
        "wl_callback"
        1
        []
        [ MessageSpec "done" 0 MessageEvent [ArgSpec "callback_data" ArgUint False]
        ]

bootstrapGetRegistry :: WireMessage
bootstrapGetRegistry =
  WireMessage
    { wireObjectId = 1
    , wireInterface = "wl_display"
    , wireMessageName = "get_registry"
    , wireOpcode = 1
    , wireArgs = [ArgNewIdValue 2]
    }

bootstrapSync :: Word32 -> WireMessage
bootstrapSync callbackId =
  WireMessage
    { wireObjectId = 1
    , wireInterface = "wl_display"
    , wireMessageName = "sync"
    , wireOpcode = 0
    , wireArgs = [ArgNewIdValue callbackId]
    }

bindingActionForObject :: RiverRuntime -> Word32 -> Maybe YAction
bindingActionForObject rt objectId = M.lookup objectId (rrBindingActions rt)