diff options
Diffstat (limited to 'wayland/Wayland/Server/Object.hs')
| -rw-r--r-- | wayland/Wayland/Server/Object.hs | 63 |
1 files changed, 42 insertions, 21 deletions
diff --git a/wayland/Wayland/Server/Object.hs b/wayland/Wayland/Server/Object.hs index b56bbaf..b13e36f 100644 --- a/wayland/Wayland/Server/Object.hs +++ b/wayland/Wayland/Server/Object.hs @@ -41,6 +41,7 @@ import Data.Kind (Type) import Data.Hashable (Hashable(..)) import Data.IORef (readIORef, newIORef, IORef, writeIORef) import Data.Typeable (Proxy(..), TypeRep, typeRep, Typeable) +import Data.ByteString (ByteString, useAsCStringLen, packCStringLen) import Foreign import Foreign.C (withCString, peekCString, CInt) import Lens.Micro.Mtl (use, (%=), zoom) @@ -113,28 +114,32 @@ class MessageClass e => EventClass e where -- For libwayland, the arguments are stored into wl_arguments. It is considered a programmer error to write more -- arguments than expected by an event or different argument types than the ones specified. class Monad m => ArgumentMarshaller m where - marshalInt :: Int -> m () - marshalUInt :: Word -> m () - marshalFixed :: Float -> m () - marshalString :: String -> m () - marshalObject :: Object o => o -> m () - marshalNewID :: Object o => NewObject o -> m () - marshalArray :: Storable a => [a] -> m () - marshalFD :: Fd -> m () + marshalInt :: Int -> m () + marshalUInt :: Word -> m () + marshalFixed :: Float -> m () + marshalString :: String -> m () + marshalMaybeString :: Maybe String -> m () + marshalObject :: Object o => o -> m () + marshalMaybeObject :: Object o => Maybe o -> m () + marshalNewID :: Object o => NewObject o -> m () + marshalArray :: ByteString -> m () + marshalFD :: Fd -> m () -- | A monad providing an environment for reading a fixed number of arguments of various types. -- -- For libwayland, the arguments are read from wl_arguments. It is considered a programmer error to read more arguments -- than expected by a request or different argument types than the ones specified. class Monad m => ArgumentDemarshaller m where - demarshalInt :: m Int - demarshalUInt :: m Word - demarshalFixed :: m Float - demarshalString :: m String - demarshalObject :: Object o => m o - demarshalNewID :: Object o => m (NewObject o) - demarshalArray :: Storable a => m [a] - demarshalFD :: m Fd + demarshalInt :: m Int + demarshalUInt :: m Word + demarshalFixed :: m Float + demarshalString :: m String + demarshalMaybeString :: m (Maybe String) + demarshalObject :: Object o => m o + demarshalMaybeObject :: Object o => m (Maybe o) + demarshalNewID :: Object o => m (NewObject o) + demarshalArray :: m ByteString + demarshalFD :: m Fd -- | An opaque handle to a Wayland object. -- @@ -202,6 +207,9 @@ instance Show AnyObject where instance Show (NewObject o) where show o = "NewObject " ++ show (newClient o) ++ " " ++ show (newID o) +instance Eq (NewObject o) where + a == b = newObject a == newObject b + -- | Create a handle to an object that has yet to be created. createNewObject :: Client -> Word32 -> IO (NewObject o) createNewObject client objID = do @@ -366,19 +374,26 @@ instance ArgumentMarshaller (ArgumentWriter r) where arg <- advanceIterator str <- liftCont $ withCString v liftIO $ wlArgumentPokeString arg str + marshalMaybeString (Just v) = marshalString v + marshalMaybeString Nothing = do + arg <- advanceIterator + liftIO $ wlArgumentPokeString arg nullPtr marshalObject v = do arg <- advanceIterator obj <- liftIO $ unwrapResource v liftIO $ wlArgumentPokeObject arg obj + marshalMaybeObject (Just v) = marshalObject v + marshalMaybeObject Nothing = do + arg <- advanceIterator + liftIO $ wlArgumentPokeObject arg (WLResource nullPtr) marshalNewID v = do arg <- advanceIterator liftIO $ wlArgumentPokeNewID arg (newID v) marshalArray v = do arg <- advanceIterator - let len = fromIntegral $ length v * sizeOf (head v) - buf <- liftCont $ withArray v - arr <- liftCont $ with $ WLArray { arrSize = len - , arrAlloc = len + (buf, len) <- liftCont $ useAsCStringLen v + arr <- liftCont $ with $ WLArray { arrSize = fromIntegral len + , arrAlloc = fromIntegral len , arrData = castPtr buf } liftIO $ wlArgumentPokeArray arg arr @@ -390,9 +405,15 @@ instance ArgumentDemarshaller ArgumentReader where demarshalString = do ptr <- advanceIterator >>= liftIO . wlArgumentPeekString liftIO $ peekCString ptr + demarshalMaybeString = do + ptr <- advanceIterator >>= liftIO . wlArgumentPeekString + if ptr == nullPtr then pure Nothing else Just <$> liftIO (peekCString ptr) demarshalObject = do ptr <- advanceIterator >>= liftIO . wlArgumentPeekObject liftIO $ wrapResource ptr + demarshalMaybeObject = do + ptr <- advanceIterator >>= liftIO . wlArgumentPeekObject + if ptr == WLResource nullPtr then pure Nothing else Just <$> liftIO (wrapResource ptr) demarshalNewID = do objID <- advanceIterator >>= liftIO . wlArgumentPeekNewID client <- ask @@ -400,5 +421,5 @@ instance ArgumentDemarshaller ArgumentReader where demarshalArray = do ptr <- advanceIterator >>= liftIO . wlArgumentPeekArray arr <- liftIO $ peek ptr - liftIO $ peekArray (fromIntegral (arrSize arr)) (castPtr (arrData arr)) + liftIO $ packCStringLen (castPtr (arrData arr), fromIntegral (arrSize arr)) demarshalFD = Fd . fromIntegral <$> (advanceIterator >>= liftIO . wlArgumentPeekFD) |