From 7fe37b76c903595205f1ac7e44948f1125bc2206 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Sun, 5 Sep 2021 21:39:39 +0200
Subject: [PATCH] Parse wayland.xml in TH
---
quasar-wayland.cabal | 12 +++++----
src/Quasar/Wayland/Protocol.hs | 29 ++++++++++++++++++++++
src/Quasar/Wayland/TH.hs | 45 ++++++++++++++++++++++++++++++++++
3 files changed, 81 insertions(+), 5 deletions(-)
create mode 100644 src/Quasar/Wayland/Protocol.hs
create mode 100644 src/Quasar/Wayland/TH.hs
diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index 65f6b2a..59a9904 100644
--- a/quasar-wayland.cabal
+++ b/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,
diff --git a/src/Quasar/Wayland/Protocol.hs b/src/Quasar/Wayland/Protocol.hs
new file mode 100644
index 0000000..24dea57
--- /dev/null
+++ b/src/Quasar/Wayland/Protocol.hs
@@ -0,0 +1,29 @@
+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)
+}
diff --git a/src/Quasar/Wayland/TH.hs b/src/Quasar/Wayland/TH.hs
new file mode 100644
index 0000000..9d8943b
--- /dev/null
+++ b/src/Quasar/Wayland/TH.hs
@@ -0,0 +1,45 @@
+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
+
--
GitLab