diff options
Diffstat (limited to 'highway')
| -rw-r--r-- | highway/Main.hs | 42 | ||||
| -rw-r--r-- | highway/highway.cabal | 2 |
2 files changed, 29 insertions, 15 deletions
diff --git a/highway/Main.hs b/highway/Main.hs index 2e8161d..3ac2152 100644 --- a/highway/Main.hs +++ b/highway/Main.hs @@ -6,8 +6,10 @@ 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.x = 0 @@ -20,13 +22,14 @@ geometry = WLOutput.Geometry { WLOutput.x = 0 , WLOutput.transform = WLOutput.TransformNormal } -data CustomRequest - = ReqBindOutput (NewObject WLOutput.WLOutput) - | ReqDestroyOutput WLOutput.WLOutput - | ReqSIGINT +data CustomMessage + = MsgBindOutput Global (NewObject WLOutput.WLOutput) + | MsgDestroyOutput WLOutput.WLOutput + | MsgSIGINT SignalSource + | MsgTimer TimerSource deriving (Typeable, Show) -instance RequestClass CustomRequest +instance MessageClass CustomMessage data Output = Output deriving (Show) @@ -38,26 +41,35 @@ data State = State { _outputs :: M.Map WLOutput.WLOutput Output 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 +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 $ "Created output, outputs: " ++ show outs + liftIO $ putStrLn $ "Output created, outputs: " ++ show outs flushEvents - | Just (ReqDestroyOutput o) <- fromRequest r = outputs %= M.delete o - | Just ReqSIGINT <- fromRequest r = do c <- interruptedCount <%= (+1) + | 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 - _ <- registerSignalEvent ReqSIGINT 2 - output <- registerGlobal ReqBindOutput 4 - processRequests handleRequest + signal <- registerSignalSource MsgSIGINT sigINT + timer <- registerTimerSource MsgTimer + setTimerSource timer $ Just (secondsToDiffTime 1) + output <- registerGlobal MsgBindOutput + processMessages handleMessage unregisterGlobal output + unregisterSignalSource signal + unregisterTimerSource timer diff --git a/highway/highway.cabal b/highway/highway.cabal index 72b1c40..60d5718 100644 --- a/highway/highway.cabal +++ b/highway/highway.cabal @@ -14,7 +14,9 @@ executable highway microlens-th, microlens-mtl, mtl, + unix, containers, + time, highway-wayland, highway-protocols default-language: Haskell2010 |