1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
{-# LANGUAGE ExistentialQuantification #-}
-- |
-- Module : Wayland.Server.Types
-- Description: Primitive types shared among other modules.
module Wayland.Server.Types
( -- * Messages
MessageClass
, Message(..)
, fromMessage
, -- * Handles
Handle
, createHandle
, resolveHandle
, invalidateHandle
) where
import System.Mem.StableName (StableName, makeStableName)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Hashable (Hashable(..))
import Data.Typeable (Typeable, cast)
-- | A message that is dispatched on the display's message loop.
class (Typeable m, Show m) => MessageClass m
-- | A type-erased message processed on the display's message loop.
data Message = forall m. MessageClass m => Message m
-- | A handle to a native pointer.
--
-- The handle remains valid and can be used for equality checks even after the underlying pointer was destroyed. This is
-- realized using an IORef which is set to nullPtr once the object is destroyed. The IORef itself is used for equality
-- checks.
data Handle ptr
= Handle { hndName :: StableName (IORef (Maybe ptr)) -- ^ Name used for hashing and ordering.
, hndPointer :: IORef (Maybe ptr) -- ^ Reference to the underlying pointer.
}
instance Eq (Handle ptr) where
a == b = hndPointer a == hndPointer b
instance Ord (Handle ptr) where
a <= b = hash (hndName a) <= hash (hndName b)
instance Hashable (Handle ptr) where
hashWithSalt s o = hashWithSalt s (hndName o)
instance Show (Handle ptr) where
show o = "Handle " ++ show (hash (hndName o))
instance Show Message where
show (Message m) = show m
-- | Try to cast a type-erased message into a concrete 'MessageClass'.
fromMessage :: MessageClass m => Message -> Maybe m
fromMessage (Message x) = cast x
-- | Create a handle wrapping a pointer.
--
-- This should only be called once for the underlying resource to ensure equality.
createHandle :: ptr -> IO (Handle ptr)
createHandle p = do
ptrRef <- newIORef $ Just p
name <- makeStableName ptrRef
return $ Handle { hndName = name
, hndPointer = ptrRef
}
-- | Get the underlying pointer for a handle.
--
-- This function may raise an error if the handle was invalidated.
resolveHandle :: Handle ptr -> IO ptr
resolveHandle h = check <$> readIORef (hndPointer h)
where check (Just p) = p
check Nothing = error "Invalid object handle."
-- | Invalidate the handle, making all further requests to 'resolveHandle' fail.
--
-- The handle itself will still remain valid and can be used to check for equality.
invalidateHandle :: Handle ptr -> IO ()
invalidateHandle h = writeIORef (hndPointer h) Nothing
|
