Parse wayland.xml in TH

quasar-wayland.cabal

@@ -83,19 +83,21 @@ common shared-executable-properties
 library
   import: shared-properties
   exposed-modules:
-    --Quasar.Template
+    Quasar.Wayland.Protocol
+    Quasar.Wayland.TH
   build-depends:
     base >=4.7 && <5,
     --binary,
-    --bytestring,
-    --exceptions,
+    bytestring,
+    exceptions,
     --mtl,
     --network,
-    --quasar,
-    --template-haskell,
+    quasar,
+    template-haskell,
     --unix,
     --unordered-containers,
     --stm,
+    xml,
     -- required for record-dot-preprocessor
     record-dot-preprocessor,
     record-hasfield,

src/Quasar/Wayland/Protocol.hs

+module Quasar.Wayland.Protocol (
+  ProtocolState,
+  initialProtocolState,
+  feedInput,
+) where
+
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as BS
+import Quasar.Prelude
+import Quasar.Wayland.TH
+
+$(generateWaylandProcol "protocols/wayland.xml")
+
+
+data ProtocolState = ProtocolState {
+  bytesReceived :: Word64,
+  bytesSent :: Word64
+}
+
+initialProtocolState :: ProtocolState
+initialProtocolState = ProtocolState {
+  bytesReceived = 0,
+  bytesSent = 0
+}
+
+feedInput :: ByteString -> ProtocolState -> (ProtocolState)
+feedInput bytes oldState = oldState {
+  bytesReceived = oldState.bytesReceived + fromIntegral (BS.length bytes)
+}

src/Quasar/Wayland/TH.hs

+module Quasar.Wayland.TH (
+  generateWaylandProcol
+) where
+
+import Quasar.Prelude
+import Text.XML.Light
+import Data.ByteString qualified as BS
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Lib
+import Language.Haskell.TH.Syntax (addDependentFile)
+
+
+generateWaylandProcol :: FilePath -> Q [Dec]
+generateWaylandProcol protocolFile = do
+  addDependentFile protocolFile
+  xml <- liftIO (BS.readFile protocolFile)
+  protocol <- loadProtocol xml
+
+  traceIO $ show $ (.name) <$> (interfaces protocol)
+
+  pure []
+
+
+data Protocol = Protocol {interfaces :: [Interface]}
+  deriving (Show)
+data Interface = Interface { name :: String }
+  deriving (Show)
+
+loadProtocol :: MonadFail m => BS.ByteString -> m Protocol
+loadProtocol xml = do
+  (Just protocolEl) <- pure $ parseXMLDoc xml
+  interfaces <- mapM loadInterface $ findChildren (blank_name { qName = "interface" }) protocolEl
+  pure $ Protocol interfaces
+
+loadInterface :: MonadFail m => Element -> m Interface
+loadInterface interfaceEl = do
+  name <- interfaceName
+  pure $ Interface name
+  where
+    interfaceName :: MonadFail m => m String
+    interfaceName = do
+      (Just name) <- pure $ findAttr (blank_name { qName = "name" }) interfaceEl
+      pure name
+