blob: 2e8161d874bb3dab318e5fb6e19e688b95390d35 (
plain)
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
|
{-# LANGUAGE TemplateHaskell #-}
import Wayland.Server
import Lens.Micro.TH (makeLenses)
import Lens.Micro.Mtl ((%=), (<%=))
import Data.Data (Typeable)
import Control.Monad (void, when)
import Control.Monad.Trans (liftIO)
import qualified Wayland.Protocols.Core.WLOutput as WLOutput
import qualified Data.Map as M
geometry :: WLOutput.Geometry
geometry = WLOutput.Geometry { WLOutput.x = 0
, WLOutput.y = 0
, WLOutput.physicalWidth = 623
, WLOutput.physicalHeight = 583
, WLOutput.subpixel = WLOutput.SubpixelNone
, WLOutput.make = "Apple"
, WLOutput.model = "Studio Display"
, WLOutput.transform = WLOutput.TransformNormal
}
data CustomRequest
= ReqBindOutput (NewObject WLOutput.WLOutput)
| ReqDestroyOutput WLOutput.WLOutput
| ReqSIGINT
deriving (Typeable, Show)
instance RequestClass CustomRequest
data Output = Output
deriving (Show)
data State = State { _outputs :: M.Map WLOutput.WLOutput Output
, _interruptedCount :: Int
}
deriving (Show)
makeLenses ''State
handleRequest :: Request -> DisplayM State ()
handleRequest r
| Just (WLOutput.ReqRelease o) <- fromRequest r = destroyObject o
| Just (ReqBindOutput o) <- fromRequest r = do output <- createObject o ReqDestroyOutput
outs <- outputs <%= M.insert output Output
sendEvent output $ WLOutput.EvGeometry geometry
sendEvent output $ WLOutput.EvDone
liftIO $ putStrLn $ "Created output, outputs: " ++ show outs
flushEvents
| Just (ReqDestroyOutput o) <- fromRequest r = outputs %= M.delete o
| Just ReqSIGINT <- fromRequest r = do c <- interruptedCount <%= (+1)
liftIO $ putStrLn $ "Received SIGINT " ++ show c ++ "/3"
when (c >= 3) requestTermination
| otherwise = pure ()
main :: IO ()
main = void $ withDisplay (State M.empty 0) $ do
socket <- bindSocket
liftIO $ putStrLn $ "Listening on socket: " ++ socket
_ <- registerSignalEvent ReqSIGINT 2
output <- registerGlobal ReqBindOutput 4
processRequests handleRequest
unregisterGlobal output
|
