Xml.hs

{-# LANGUAGE Arrows #-}
{-# LANGUAGE OverloadedStrings #-}

module YMonad.Protocol.Wayland.Xml (
  loadProtocolSpec,
) where

import Data.Map.Strict qualified as M
import Text.XML.HXT.Core

import YMonad.Protocol.Wayland.Types

loadProtocolSpec :: FilePath -> IO (Either String ProtocolSpec)
loadProtocolSpec path = do
  specs <- runX (readDocument [withValidate no, withRemoveWS yes] path >>> parseProtocol)
  pure $ case specs of
    [] -> Left ("No <protocol> element found in: " <> path)
    spec : _ -> Right spec

parseProtocol :: IOSArrow XmlTree ProtocolSpec
parseProtocol =
  deep (isElem >>> hasName "protocol") >>> proc proto -> do
    name <- getAttrValue "name" -< proto
    interfaces <- listA (getChildren >>> isElem >>> hasName "interface" >>> parseInterface) -< proto
    returnA
      -<
        ProtocolSpec
          { protocolName = toText name
          , protocolInterfaces = M.fromList [(interfaceName iface, iface) | iface <- interfaces]
          }

parseInterface :: IOSArrow XmlTree InterfaceSpec
parseInterface = proc iface -> do
  name <- getAttrValue "name" -< iface
  versionTxt <- getAttrValue "version" -< iface
  requests <- listA (getChildren >>> isElem >>> hasName "request" >>> parseRequest) -< iface
  events <- listA (getChildren >>> isElem >>> hasName "event" >>> parseEvent) -< iface
  let version = parseWord32 1 versionTxt
  returnA -< mkInterfaceSpec (toText name) version (assignOpcodes MessageRequest requests) (assignOpcodes MessageEvent events)

parseRequest :: IOSArrow XmlTree MessageSpec
parseRequest = parseMessage MessageRequest

parseEvent :: IOSArrow XmlTree MessageSpec
parseEvent = parseMessage MessageEvent

parseMessage :: MessageRole -> IOSArrow XmlTree MessageSpec
parseMessage role = proc msg -> do
  name <- getAttrValue "name" -< msg
  args <- listA (getChildren >>> isElem >>> hasName "arg" >>> parseArg) -< msg
  returnA
    -<
      MessageSpec
        { messageSpecName = toText name
        , messageSpecOpcode = 0
        , messageSpecRole = role
        , messageSpecArgs = args
        }

parseArg :: IOSArrow XmlTree ArgSpec
parseArg = proc arg -> do
  name <- getAttrValue "name" -< arg
  typeName <- getAttrValue "type" -< arg
  iface <- getAttrValue "interface" -< arg
  allowNull <- getAttrValue "allow-null" -< arg
  returnA
    -<
      ArgSpec
        { argSpecName = toText name
        , argSpecType = parseArgType (toText typeName) (toMaybeText iface)
        , argSpecAllowNull = allowNull == "true"
        }

assignOpcodes :: MessageRole -> [MessageSpec] -> [MessageSpec]
assignOpcodes role = zipWith assign [0 :: Word16 ..]
  where
    assign opcode spec = spec {messageSpecOpcode = opcode, messageSpecRole = role}

parseArgType :: Text -> Maybe Text -> ArgType
parseArgType typeName iface = case typeName of
  "int" -> ArgInt
  "uint" -> ArgUint
  "string" -> ArgString
  "object" -> ArgObject iface
  "new_id" -> ArgNewId iface
  _ -> ArgString

parseWord32 :: Word32 -> String -> Word32
parseWord32 fallback raw = fromMaybe fallback (readMaybe raw)

toMaybeText :: String -> Maybe Text
toMaybeText "" = Nothing
toMaybeText raw = Just (toText raw)