blob: 8f6bcd65b497d5ae8e022d9ec180b7b47414f725 (
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
64
65
66
67
68
69
70
71
72
73
74
75
|
{-# 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 System.Posix.Signals (sigINT)
import qualified Wayland.Protocols.Core.WlOutput as WlOutput
import qualified Data.Map as M
import Data.Time (secondsToDiffTime)
geometry :: WlOutput.Geometry
geometry = WlOutput.Geometry { WlOutput.geometryX = 0
, WlOutput.geometryY = 0
, WlOutput.geometryPhysicalWidth = 623
, WlOutput.geometryPhysicalHeight = 583
, WlOutput.geometrySubpixel = WlOutput.SubpixelNone
, WlOutput.geometryMake = "Apple"
, WlOutput.geometryModel = "Studio Display"
, WlOutput.geometryTransform = WlOutput.TransformNormal
}
data CustomMessage
= MsgBindOutput Global (NewObject WlOutput.Object)
| MsgDestroyOutput WlOutput.Object
| MsgSIGINT SignalSource
| MsgTimer TimerSource
deriving (Typeable, Show)
instance MessageClass CustomMessage
data Output = Output
deriving (Show)
data State = State { _outputs :: M.Map WlOutput.Object Output
, _interruptedCount :: Int
}
deriving (Show)
makeLenses ''State
handleMessage :: Message -> DisplayM State ()
handleMessage m
| Just (WlOutput.ReqRelease o) <- fromMessage m = destroyObject o
| Just (MsgBindOutput _ o) <- fromMessage m = do output <- createObject o MsgDestroyOutput
outs <- outputs <%= M.insert output Output
sendEvent output $ WlOutput.EvGeometry geometry
sendEvent output $ WlOutput.EvDone
liftIO $ putStrLn $ "Output created, outputs: " ++ show outs
flushEvents
| Just (MsgDestroyOutput o) <- fromMessage m = do outputs %= M.delete o
liftIO $ putStrLn $ "Output destroyed: " ++ show o
| Just (MsgSIGINT _) <- fromMessage m = do c <- interruptedCount <%= (+1)
liftIO $ putStrLn $ "Received SIGINT " ++ show c ++ "/3"
when (c >= 3) requestTermination
| Just (MsgTimer t) <- fromMessage m = do liftIO $ putStrLn "Timeout passed"
setTimerSource t $ Just (secondsToDiffTime 2)
| Just (ClientCreated c) <- fromMessage m = liftIO $ putStrLn $ "Client created: " ++ show c
| Just (ClientDestroyed c) <- fromMessage m = liftIO $ putStrLn $ "Client destroyed: " ++ show c
| otherwise = pure ()
main :: IO ()
main = void $ withDisplay (State M.empty 0) $ do
socket <- bindSocket
liftIO $ putStrLn $ "Listening on socket: " ++ socket
signal <- registerSignalSource MsgSIGINT sigINT
timer <- registerTimerSource MsgTimer
setTimerSource timer $ Just (secondsToDiffTime 1)
output <- registerGlobal MsgBindOutput
processMessages handleMessage
unregisterGlobal output
unregisterSignalSource signal
unregisterTimerSource timer
|
