Types.hs

module YMonad.Protocol.Wayland.Types (
  MessageRole (..),
  ArgType (..),
  ArgSpec (..),
  MessageSpec (..),
  InterfaceSpec (..),
  ProtocolSpec (..),
  ArgValue (..),
  WireMessage (..),
  RawFrame (..),
  mkInterfaceSpec,
  mergeProtocolSpecs,
  lookupInterface,
  lookupRequest,
  lookupEventByOpcode,
) where

import Data.Map.Strict qualified as M

data MessageRole
  = MessageRequest
  | MessageEvent
  deriving stock (Eq, Ord, Show)

data ArgType
  = ArgInt
  | ArgUint
  | ArgString
  | ArgObject (Maybe Text)
  | ArgNewId (Maybe Text)
  deriving stock (Eq, Ord, Show)

data ArgSpec = ArgSpec
  { argSpecName :: Text
  , argSpecType :: ArgType
  , argSpecAllowNull :: Bool
  }
  deriving stock (Eq, Ord, Show)

data MessageSpec = MessageSpec
  { messageSpecName :: Text
  , messageSpecOpcode :: Word16
  , messageSpecRole :: MessageRole
  , messageSpecArgs :: [ArgSpec]
  }
  deriving stock (Eq, Ord, Show)

data InterfaceSpec = InterfaceSpec
  { interfaceName :: Text
  , interfaceVersion :: Word32
  , interfaceRequestsByName :: Map Text MessageSpec
  , interfaceRequestsByOpcode :: Map Word16 MessageSpec
  , interfaceEventsByName :: Map Text MessageSpec
  , interfaceEventsByOpcode :: Map Word16 MessageSpec
  }
  deriving stock (Eq, Ord, Show)

data ProtocolSpec = ProtocolSpec
  { protocolName :: Text
  , protocolInterfaces :: Map Text InterfaceSpec
  }
  deriving stock (Eq, Ord, Show)

data ArgValue
  = ArgIntValue Int32
  | ArgUintValue Word32
  | ArgStringValue (Maybe Text)
  | ArgObjectValue (Maybe Word32)
  | ArgNewIdValue Word32
  deriving stock (Eq, Ord, Show)

data WireMessage = WireMessage
  { wireObjectId :: Word32
  , wireInterface :: Text
  , wireMessageName :: Text
  , wireOpcode :: Word16
  , wireArgs :: [ArgValue]
  }
  deriving stock (Eq, Ord, Show)

data RawFrame = RawFrame
  { rawObjectId :: Word32
  , rawOpcode :: Word16
  , rawPayload :: !ByteString
  }
  deriving stock (Eq, Ord, Show)

mkInterfaceSpec :: Text -> Word32 -> [MessageSpec] -> [MessageSpec] -> InterfaceSpec
mkInterfaceSpec name version requests events =
  InterfaceSpec
    { interfaceName = name
    , interfaceVersion = version
    , interfaceRequestsByName = M.fromList [(messageSpecName msg, msg) | msg <- requests]
    , interfaceRequestsByOpcode = M.fromList [(messageSpecOpcode msg, msg) | msg <- requests]
    , interfaceEventsByName = M.fromList [(messageSpecName msg, msg) | msg <- events]
    , interfaceEventsByOpcode = M.fromList [(messageSpecOpcode msg, msg) | msg <- events]
    }

mergeProtocolSpecs :: ProtocolSpec -> ProtocolSpec -> ProtocolSpec
mergeProtocolSpecs a b =
  ProtocolSpec
    { protocolName = protocolName a
    , protocolInterfaces = M.union (protocolInterfaces a) (protocolInterfaces b)
    }

lookupInterface :: ProtocolSpec -> Text -> Maybe InterfaceSpec
lookupInterface spec name = M.lookup name (protocolInterfaces spec)

lookupRequest :: ProtocolSpec -> Text -> Text -> Maybe MessageSpec
lookupRequest spec ifaceName msgName = do
  iface <- lookupInterface spec ifaceName
  M.lookup msgName (interfaceRequestsByName iface)

lookupEventByOpcode :: ProtocolSpec -> Text -> Word16 -> Maybe MessageSpec
lookupEventByOpcode spec ifaceName opcode = do
  iface <- lookupInterface spec ifaceName
  M.lookup opcode (interfaceEventsByOpcode iface)