diff options
Diffstat (limited to 'protocols/Wayland/Protocols/Core/WLOutput.hs')
| -rw-r--r-- | protocols/Wayland/Protocols/Core/WLOutput.hs | 192 |
1 files changed, 137 insertions, 55 deletions
diff --git a/protocols/Wayland/Protocols/Core/WLOutput.hs b/protocols/Wayland/Protocols/Core/WLOutput.hs index 1274855..d6adda2 100644 --- a/protocols/Wayland/Protocols/Core/WLOutput.hs +++ b/protocols/Wayland/Protocols/Core/WLOutput.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Wayland.Protocols.Core.WLOutput ( Subpixel(..) @@ -12,10 +13,72 @@ module Wayland.Protocols.Core.WLOutput ) where import Data.Data (Typeable) -import Wayland.Server (ResourceClass(..), RequestClass, InterfaceDesc(..), MessageDesc(..), ArgumentDesc(..), Nullability(..), ObjectID) +import Wayland.Server (ResourceClass(..), RequestClass, InterfaceDesc(..), MessageDesc(..), ArgumentDesc(..), Nullability(..), ObjectID, EventClass, marshalInt, marshalString, marshalUInt) +import Data.Hashable (Hashable(..)) newtype Handle = Handle ObjectID - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Hashable) + +reqRelease :: MessageDesc +reqRelease = MessageDesc { msgName = "release" + , msgSignature = [] + , msgSince = 3 + , msgIsDestructor = True + } + +evGeometry :: MessageDesc +evGeometry = MessageDesc { msgName = "geometry" + , msgSignature = [ ArgumentInt + , ArgumentInt + , ArgumentInt + , ArgumentInt + , ArgumentInt + , ArgumentString NotNull + , ArgumentString NotNull + , ArgumentInt + ] + , msgSince = 1 + , msgIsDestructor = False + } + +evMode :: MessageDesc +evMode = MessageDesc { msgName = "mode" + , msgSignature = [ ArgumentUInt + , ArgumentInt + , ArgumentInt + , ArgumentInt + ] + , msgSince = 1 + , msgIsDestructor = False + } + +evDone :: MessageDesc +evDone = MessageDesc { msgName = "done" + , msgSignature = [] + , msgSince = 2 + , msgIsDestructor = False + } + +evScale :: MessageDesc +evScale = MessageDesc { msgName = "scale" + , msgSignature = [ ArgumentInt ] + , msgSince = 2 + , msgIsDestructor = False + } + +evName :: MessageDesc +evName = MessageDesc { msgName = "name" + , msgSignature = [ ArgumentString NotNull ] + , msgSince = 4 + , msgIsDestructor = False + } + +evDescription :: MessageDesc +evDescription = MessageDesc { msgName = "description" + , msgSignature = [ ArgumentString NotNull ] + , msgSince = 4 + , msgIsDestructor = False + } instance ResourceClass Handle where type ResourceEvent Handle = Event @@ -24,57 +87,56 @@ instance ResourceClass Handle where fromID = Handle interface _ = InterfaceDesc { ifName = "wl_output" , ifVersion = 4 - , ifRequests = [ MessageDesc { msgName = "release" - , msgSignature = [] - , msgSince = 3 - , msgIsDestructor = True - } - ] - , ifEvents = [ MessageDesc { msgName = "geometry" - , msgSignature = [ ArgumentInt - , ArgumentInt - , ArgumentInt - , ArgumentInt - , ArgumentInt - , ArgumentString NotNull - , ArgumentString NotNull - , ArgumentInt - ] - , msgSince = 1 - , msgIsDestructor = False - } - , MessageDesc { msgName = "mode" - , msgSignature = [ ArgumentUInt - , ArgumentInt - , ArgumentInt - , ArgumentInt - ] - , msgSince = 1 - , msgIsDestructor = False - } - , MessageDesc { msgName = "done" - , msgSignature = [] - , msgSince = 2 - , msgIsDestructor = False - } - , MessageDesc { msgName = "scale" - , msgSignature = [ ArgumentInt ] - , msgSince = 2 - , msgIsDestructor = False - } - , MessageDesc { msgName = "name" - , msgSignature = [ ArgumentString NotNull ] - , msgSince = 4 - , msgIsDestructor = False - } - , MessageDesc { msgName = "description" - , msgSignature = [ ArgumentString NotNull ] - , msgSince = 4 - , msgIsDestructor = False - } - ] + , ifRequests = [ reqRelease ] + , ifEvents = [ evGeometry + , evMode + , evDone + , evScale + , evName + , evDescription ] } + demarshalRequest r 0 = do + pure (ReqRelease r) + demarshalRequest _ _ = fail "Unknown opcode." + + marshalEvent _ (EvGeometry p) = do + marshalInt (x p) + marshalInt (y p) + marshalInt (physicalWidth p) + marshalInt (physicalHeight p) + marshalInt (fromEnum (subpixel p)) + marshalString (make p) + marshalString (model p) + marshalInt (fromEnum (transform p)) + pure 0 + marshalEvent _ (EvMode p) = do + marshalUInt (fromBitSet (flags p)) + marshalInt (width p) + marshalInt (height p) + marshalInt (refresh p) + pure 1 + marshalEvent _ EvDone = do + pure 2 + marshalEvent _ (EvScale p) = do + marshalInt p + pure 3 + marshalEvent _ (EvName p) = do + marshalString p + pure 4 + marshalEvent _ (EvDescription p) = do + marshalString p + pure 5 + + requestSignature _ (ReqRelease _) = reqRelease + + eventSignature _ (EvGeometry _) = evGeometry + eventSignature _ (EvMode _) = evMode + eventSignature _ EvDone = evDone + eventSignature _ (EvScale _) = evScale + eventSignature _ (EvName _) = evName + eventSignature _ (EvDescription _) = evDescription + data Subpixel = SubpixelUnknown | SubpixelNone @@ -82,6 +144,7 @@ data Subpixel | SubpixelHorizontalBgr | SubpixelVerticalRgb | SubpixelVerticalBgr + deriving (Show, Enum) data Transform = TransformNormal @@ -92,10 +155,24 @@ data Transform | TransformFlipped90 | TransformFlipped180 | TransformFlipped270 + deriving (Show, Enum) + +data ModeFlags + = ModeFlags { current :: Bool + , preferred :: Bool + } + deriving (Show) + +fromBitSet :: ModeFlags -> Word +fromBitSet _ = 0 data Mode - = Mode { current :: Bool - , preferred :: Bool } + = Mode { flags :: ModeFlags + , width :: Int + , height :: Int + , refresh :: Int + } + deriving (Show) data Geometry = Geometry { x :: Int @@ -105,13 +182,15 @@ data Geometry , subpixel :: Subpixel , make :: String , model :: String - , transform :: Transform } + , transform :: Transform + } + deriving (Show) data Request = ReqRelease Handle deriving (Typeable, Show) -instance RequestClass Request +instance RequestClass Request where data Event = EvGeometry Geometry @@ -120,3 +199,6 @@ data Event | EvName String | EvDescription String | EvDone + deriving (Typeable, Show) + +instance EventClass Event where |