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
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Wayland.Server
( Request(..)
, ObjectID
, Global
, DisplayM(..)
, ResourceClass(..)
, InterfaceDesc(..)
, MessageDesc(..)
, ArgumentDesc(..)
, Nullability(..)
, fromRequest
, withDisplay
, bindSocket
, processRequests
, flushEvents
, sendEvent
, destroyResource
, registerGlobal
, unregisterGlobal
) where
import Data.Typeable (Typeable, Proxy, cast)
import Data.Kind (Type)
import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..), runStateT, gets)
import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed)
import Wayland.Server.System
import Control.Monad.Trans (MonadTrans(..))
import Foreign.C (peekCString)
data DisplayState
= DisplayState { display :: WLDisplay
}
data Global = Global
newtype ObjectID = ObjectID String
deriving (Show, Eq, Ord)
data Nullability
= AllowNull
| NotNull
data ArgumentDesc
= ArgumentInt
| ArgumentUInt
| ArgumentFixed
| ArgumentString !Nullability
| ArgumentObject !Nullability
| ArgumentNewID
| ArgumentArray
| ArgumentFD
data MessageDesc
= MessageDesc { msgName :: !String
, msgSignature :: ![ArgumentDesc]
, msgSince :: !Int
, msgIsDestructor :: !Bool
, msgCreatedInterface :: !(Maybe InterfaceDesc)
, msgArgumentInterface :: ![InterfaceDesc]
}
data InterfaceDesc
= InterfaceDesc { ifName :: !String
, ifVersion :: !Int
, ifRequests :: ![MessageDesc]
, ifEvents :: ![MessageDesc]
}
class ResourceClass r where
type ResourceRequest r :: Type
type ResourceEvent r :: Type
objectID :: r -> ObjectID
interface :: Proxy r -> InterfaceDesc
data Request = forall a. Typeable a => Request a
newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (StateT DisplayState IO) a }
deriving (Functor, Applicative, Monad, MonadIO, MonadState s)
type instance Zoomed (DisplayM s) = Zoomed (StateT s (StateT DisplayState IO))
instance Zoom (DisplayM s) (DisplayM t) s t where
zoom l (DisplayM m) = DisplayM (zoom l m)
fromRequest :: Typeable a => Request -> Maybe a
fromRequest (Request x) = cast x
withDisplay :: s -> DisplayM s a -> IO (a, s)
withDisplay initialState f = do
disp <- wlDisplayCreate
let dispState = DisplayState { display = disp }
(res, _) <-runStateT (runStateT (runDisplayM f) initialState) dispState
wlDisplayDestroy disp
return res
bindSocket :: DisplayM s String
bindSocket = do
disp <- DisplayM $ lift $ gets display
name <- liftIO $ wlDisplayAddSocketAuto disp
liftIO $ peekCString name
processRequests :: (Request -> DisplayM s ()) -> DisplayM s ()
processRequests _ = do
disp <- DisplayM $ lift $ gets display
liftIO $ wlDisplayRun disp
sendEvent :: ResourceClass r => r -> ResourceEvent r -> DisplayM s ()
sendEvent _ _ = undefined
flushEvents :: DisplayM s ()
flushEvents = undefined
destroyResource :: ResourceClass r => r -> DisplayM s ()
destroyResource _ = undefined
registerGlobal :: ResourceClass r => Typeable req => (r -> req) -> DisplayM s Global
registerGlobal _ = pure Global
unregisterGlobal :: Global -> DisplayM s ()
unregisterGlobal _ = pure ()
|
