Skip to content
Snippets Groups Projects
Commit b7df69ef authored by Jens Nolte's avatar Jens Nolte
Browse files

Import Core in TH module

parent 0cfbc34a
No related branches found
No related tags found
No related merge requests found
module Quasar.Wayland.Core ( module Quasar.Wayland.Core (
ObjectId,
Opcode,
ProtocolState, ProtocolState,
ClientProtocolState, ClientProtocolState,
initialClientProtocolState, initialClientProtocolState,
......
...@@ -9,7 +9,7 @@ import Data.ByteString qualified as BS ...@@ -9,7 +9,7 @@ import Data.ByteString qualified as BS
import Language.Haskell.TH import Language.Haskell.TH
import Language.Haskell.TH.Lib import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax (addDependentFile) import Language.Haskell.TH.Syntax (addDependentFile)
--import Quasar.Wayland.Core import Quasar.Wayland.Core
...@@ -24,61 +24,59 @@ generateWaylandProcol protocolFile = do ...@@ -24,61 +24,59 @@ generateWaylandProcol protocolFile = do
pure [] pure []
type Opcode = Word16 data ProtocolSpec = ProtocolSpec {interfaces :: [InterfaceSpec]}
data Protocol = Protocol {interfaces :: [Interface]}
deriving stock (Show) deriving stock (Show)
data Interface = Interface { data InterfaceSpec = InterfaceSpec {
name :: String, name :: String,
requests :: [Request], requests :: [RequestSpec],
events :: [Event] events :: [EventSpec]
} }
deriving stock (Show) deriving stock (Show)
data Request = Request { data RequestSpec = RequestSpec {
name :: String, name :: String,
opcode :: Opcode opcode :: Opcode
} }
deriving stock (Show) deriving stock (Show)
data Event = Event { data EventSpec = EventSpec {
name :: String, name :: String,
opcode :: Opcode opcode :: Opcode
} }
deriving stock (Show) deriving stock (Show)
parseProtocol :: MonadFail m => BS.ByteString -> m Protocol parseProtocol :: MonadFail m => BS.ByteString -> m ProtocolSpec
parseProtocol xml = do parseProtocol xml = do
(Just element) <- pure $ parseXMLDoc xml (Just element) <- pure $ parseXMLDoc xml
interfaces <- mapM parseInterface $ findChildren (blank_name { qName = "interface" }) element interfaces <- mapM parseInterface $ findChildren (blank_name { qName = "interface" }) element
pure Protocol { pure ProtocolSpec {
interfaces interfaces
} }
parseInterface :: MonadFail m => Element -> m Interface parseInterface :: MonadFail m => Element -> m InterfaceSpec
parseInterface element = do parseInterface element = do
name <- getAttr "name" element name <- getAttr "name" element
requests <- mapM parseRequest $ zip [0..] $ findChildren (qname "request") element requests <- mapM parseRequest $ zip [0..] $ findChildren (qname "request") element
events <- mapM parseEvent $ zip [0..] $ findChildren (qname "events") element events <- mapM parseEvent $ zip [0..] $ findChildren (qname "events") element
pure Interface { pure InterfaceSpec {
name, name,
requests, requests,
events events
} }
parseRequest :: MonadFail m => (Opcode, Element) -> m Request parseRequest :: MonadFail m => (Opcode, Element) -> m RequestSpec
parseRequest (opcode, element) = do parseRequest (opcode, element) = do
name <- getAttr "name" element name <- getAttr "name" element
pure Request { pure RequestSpec {
name, name,
opcode opcode
} }
parseEvent :: MonadFail m => (Opcode, Element) -> m Event parseEvent :: MonadFail m => (Opcode, Element) -> m EventSpec
parseEvent (opcode, element) = do parseEvent (opcode, element) = do
name <- getAttr "name" element name <- getAttr "name" element
pure Event { pure EventSpec {
name, name,
opcode opcode
} }
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment