parse protocol spec

2 files changed, 233 insertions, 0 deletions

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