diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs index b4877e709fd8b50ea72624dcf39bae5b501f163c..a6c40c607b39b4ac5e36884e0ff07b1f3e2faf41 100644 --- a/src/Quasar/Wayland/Protocol/Core.hs +++ b/src/Quasar/Wayland/Protocol/Core.hs @@ -92,56 +92,67 @@ class (Eq (Argument a), Show (Argument a)) => WireFormat a where type Argument a putArgument :: Argument a -> PutM () getArgument :: Get (Argument a) + showArgument :: Argument a -> String instance WireFormat 'IntArgument where type Argument 'IntArgument = Int32 putArgument = putInt32host getArgument = getInt32host + showArgument = show instance WireFormat 'UIntArgument where type Argument 'UIntArgument = Word32 putArgument = putWord32host getArgument = getWord32host + showArgument = show instance WireFormat 'FixedArgument where type Argument 'FixedArgument = Fixed putArgument (Fixed repr) = putWord32host repr getArgument = Fixed <$> getWord32host + showArgument = show instance WireFormat 'StringArgument where type Argument 'StringArgument = BS.ByteString putArgument = putWaylandBlob getArgument = getWaylandBlob + showArgument = show instance WireFormat 'ArrayArgument where type Argument 'ArrayArgument = BS.ByteString putArgument = putWaylandBlob getArgument = getWaylandBlob + showArgument array = "[array " <> show (BS.length array) <> "B]" instance WireFormat 'ObjectArgument where type Argument 'ObjectArgument = ObjectId putArgument = putWord32host getArgument = getWord32host + showArgument oId = "@" <> show oId instance WireFormat 'UnknownObjectArgument where type Argument 'UnknownObjectArgument = ObjectId putArgument = putWord32host getArgument = getWord32host + showArgument oId = "@" <> show oId instance WireFormat 'NewIdArgument where type Argument 'NewIdArgument = NewId putArgument (NewId newId) = putWord32host newId getArgument = NewId <$> getWord32host + showArgument newId = "new @" <> show newId instance WireFormat 'UnknownNewIdArgument where type Argument 'UnknownNewIdArgument = NewId putArgument (NewId newId) = putWord32host newId getArgument = NewId <$> getWord32host + showArgument newId = "new @" <> show newId instance WireFormat 'FdArgument where type Argument 'FdArgument = Void putArgument = undefined getArgument = undefined + showArgument = undefined -- | A wayland interface @@ -269,7 +280,6 @@ putDynamicArgument (DynamicNewIdArgument x) = putWord32host x putDynamicArgument _ = undefined - type ClientProtocolState m = ProtocolState 'Client m type ServerProtocolState m = ProtocolState 'Server m