From ea6a270a481ae9c5ce6d3d2508c61734b8fd137d Mon Sep 17 00:00:00 2001 From: Hannes Schulze Date: Thu, 8 Aug 2024 23:59:07 +0200 Subject: parse protocol spec --- protocols/codegen/Wayland/CodeGen/Parser.hs | 142 ++++++++++++++++++++++++++++ protocols/codegen/Wayland/CodeGen/Types.hs | 91 ++++++++++++++++++ 2 files changed, 233 insertions(+) create mode 100644 protocols/codegen/Wayland/CodeGen/Parser.hs create mode 100644 protocols/codegen/Wayland/CodeGen/Types.hs (limited to 'protocols/codegen/Wayland/CodeGen') diff --git a/protocols/codegen/Wayland/CodeGen/Parser.hs b/protocols/codegen/Wayland/CodeGen/Parser.hs new file mode 100644 index 0000000..63ba2c4 --- /dev/null +++ b/protocols/codegen/Wayland/CodeGen/Parser.hs @@ -0,0 +1,142 @@ +module Wayland.CodeGen.Parser + ( parseProtocolSpec + ) where + +import Text.XML.Light (Element(..), findAttrBy, QName(..), filterChildName, filterChildrenName, strContent, parseXMLDoc) +import Text.Read (readEither) +import Wayland.CodeGen.Types + +parseProtocolSpec :: String -> Either String Protocol +parseProtocolSpec s = case parseXMLDoc s of + Just el | matchName "protocol" (elName el) -> processProtocol el + _ -> Left "Invalid XML" + +processProtocol :: Element -> Either String Protocol +processProtocol el = do + name <- requireAttr "name" el + description <- traverse processDescription (filterChildName (matchName "description") el) + interfaces <- mapM processInterface (filterChildrenName (matchName "interface") el) + let copyright = strContent <$> filterChildName (matchName "copyright") el + pure $ Protocol { protName = name + , protCopyright = copyright + , protDescription = description + , protInterfaces = interfaces + } + +processDescription :: Element -> Either String Description +processDescription el = do + summary <- requireAttr "summary" el + pure $ Description { descSummary = summary + , descBody = strContent el + } + +processInterface :: Element -> Either String InterfaceDesc +processInterface el = do + name <- requireAttr "name" el + version <- requireAttr "version" el >>= readEither + description <- traverse processDescription (filterChildName (matchName "description") el) + enums <- mapM processEnum (filterChildrenName (matchName "enum") el) + requests <- mapM processMessage (filterChildrenName (matchName "request") el) + events <- mapM processMessage (filterChildrenName (matchName "event") el) + pure $ InterfaceDesc { ifName = name + , ifVersion = version + , ifDescription = description + , ifEnums = enums + , ifRequests = requests + , ifEvents = events + } + +processEnum :: Element -> Either String EnumDesc +processEnum el = do + name <- requireAttr "name" el + description <- traverse processDescription (filterChildName (matchName "description") el) + since <- traverse readEither (findAttrBy (matchName "since") el) + bitfield <- traverse readBool (findAttrBy (matchName "bitfield") el) + entries <- mapM processEntry (filterChildrenName (matchName "entry") el) + pure $ EnumDesc { enumName = name + , enumDescription = description + , enumSince = since + , enumBitfield = bitfield + , enumEntries = entries + } + +processEntry :: Element -> Either String EntryDesc +processEntry el = do + name <- requireAttr "name" el + value <- requireAttr "value" el >>= readEither + description <- traverse processDescription (filterChildName (matchName "description") el) + since <- traverse readEither (findAttrBy (matchName "since") el) + deprecatedSince <- traverse readEither (findAttrBy (matchName "deprecated-since") el) + let summary = findAttrBy (matchName "summary") el + pure $ EntryDesc { entryName = name + , entryValue = value + , entryDescription = description + , entrySummary = summary + , entrySince = since + , entryDeprecatedSince = deprecatedSince + } + +processMessage :: Element -> Either String MessageDesc +processMessage el = do + name <- requireAttr "name" el + description <- traverse processDescription (filterChildName (matchName "description") el) + type' <- traverse readMessageType (findAttrBy (matchName "type") el) + since <- traverse readEither (findAttrBy (matchName "since") el) + deprecatedSince <- traverse readEither (findAttrBy (matchName "deprecated-since") el) + arguments <- mapM processArgument (filterChildrenName (matchName "arg") el) + pure $ MessageDesc { msgName = name + , msgDescription = description + , msgType = type' + , msgSince = since + , msgDeprecatedSince = deprecatedSince + , msgArguments = arguments + } + +processArgument :: Element -> Either String ArgumentDesc +processArgument el = do + name <- requireAttr "name" el + type' <- requireAttr "type" el >>= readArgumentType + description <- traverse processDescription (filterChildName (matchName "description") el) + allowNull <- traverse readBool (findAttrBy (matchName "allow-null") el) + let summary = findAttrBy (matchName "summary") el + let interface = findAttrBy (matchName "interface") el + let enum = findAttrBy (matchName "enum") el + pure $ ArgumentDesc { argName = name + , argType = type' + , argDescription = description + , argSummary = summary + , argInterface = interface + , argAllowNull = allowNull + , argEnum = enum + } + +requireAttr :: String -> Element -> Either String String +requireAttr name el = expect ("Expected attribute " ++ name) $ findAttrBy (matchName name) el + +matchName :: String -> QName -> Bool +matchName name q = qName q == name + +expect :: String -> Maybe a -> Either String a +expect _ (Just x) = Right x +expect e Nothing = Left e + +readBool :: String -> Either String Bool +readBool "true" = Right True +readBool "false" = Right False +readBool x = Left $ "Expected a boolean value, got " ++ x + +readMessageType :: String -> Either String MessageType +readMessageType "destructor" = Right MessageDestructor +readMessageType "normal" = Right MessageNormal +readMessageType x = Left $ "Expected a message type, got " ++ x + +readArgumentType :: String -> Either String ArgumentType +readArgumentType "int" = Right ArgumentInt +readArgumentType "uint" = Right ArgumentUInt +readArgumentType "fixed" = Right ArgumentFixed +readArgumentType "string" = Right ArgumentString +readArgumentType "array" = Right ArgumentArray +readArgumentType "fd" = Right ArgumentFD +readArgumentType "new_id" = Right ArgumentNewID +readArgumentType "object" = Right ArgumentObject +readArgumentType x = Left $ "Expected an argument type, got " ++ x diff --git a/protocols/codegen/Wayland/CodeGen/Types.hs b/protocols/codegen/Wayland/CodeGen/Types.hs new file mode 100644 index 0000000..b783a7c --- /dev/null +++ b/protocols/codegen/Wayland/CodeGen/Types.hs @@ -0,0 +1,91 @@ +module Wayland.CodeGen.Types + ( Protocol(..) + , InterfaceDesc(..) + , EnumDesc(..) + , EntryDesc(..) + , MessageDesc(..) + , MessageType(..) + , ArgumentDesc(..) + , ArgumentType(..) + , Description(..) + ) where + +data Protocol + = Protocol { protName :: !String + , protCopyright :: !(Maybe String) + , protDescription :: !(Maybe Description) + , protInterfaces :: ![InterfaceDesc] + } + deriving Show + +data InterfaceDesc + = InterfaceDesc { ifName :: !String + , ifVersion :: !Int + , ifDescription :: !(Maybe Description) + , ifEnums :: ![EnumDesc] + , ifRequests :: ![MessageDesc] + , ifEvents :: ![MessageDesc] + } + deriving Show + +data EnumDesc + = EnumDesc { enumName :: !String + , enumDescription :: !(Maybe Description) + , enumSince :: !(Maybe Int) + , enumBitfield :: !(Maybe Bool) + , enumEntries :: ![EntryDesc] + } + deriving Show + +data EntryDesc + = EntryDesc { entryName :: !String + , entryValue :: !Int + , entryDescription :: !(Maybe Description) + , entrySummary :: !(Maybe String) + , entrySince :: !(Maybe Int) + , entryDeprecatedSince :: !(Maybe Int) + } + deriving Show + +data MessageDesc + = MessageDesc { msgName :: !String + , msgDescription :: !(Maybe Description) + , msgType :: !(Maybe MessageType) + , msgSince :: !(Maybe Int) + , msgDeprecatedSince :: !(Maybe Int) + , msgArguments :: ![ArgumentDesc] + } + deriving Show + +data MessageType + = MessageNormal + | MessageDestructor + deriving Show + +data ArgumentDesc + = ArgumentDesc { argName :: !String + , argType :: !ArgumentType + , argDescription :: !(Maybe Description) + , argSummary :: !(Maybe String) + , argInterface :: !(Maybe String) + , argAllowNull :: !(Maybe Bool) + , argEnum :: !(Maybe String) + } + deriving Show + +data ArgumentType + = ArgumentInt + | ArgumentUInt + | ArgumentFixed + | ArgumentString + | ArgumentArray + | ArgumentFD + | ArgumentNewID + | ArgumentObject + deriving Show + +data Description + = Description { descSummary :: !String + , descBody :: !String + } + deriving Show -- cgit v1.3.1