1 files changed, 48 insertions, 0 deletions
diff --git a/highway/Main.hs b/highway/Main.hs
new file mode 100644
index 0000000..17b768d
--- /dev/null
+++ b/highway/Main.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+import Wayland.Server
+import Lens.Micro.TH (makeLenses)
+import Lens.Micro.Mtl ((%=))
+import Data.Data (Typeable)
+import Control.Monad (void)
+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  = 5120
+                             , WLOutput.physicalHeight = 2880
+                             , WLOutput.subpixel       = WLOutput.SubpixelNone
+                             , WLOutput.make           = "Apple"
+                             , WLOutput.model          = "Studio Display"
+                             , WLOutput.transform      = WLOutput.TransformNormal
+                             }
+
+data BindRequest
+  = BindOutput WLOutput.Handle
+  deriving (Typeable, Show)
+
+data Output = Output
+
+data State = State { _outputs :: M.Map WLOutput.Handle Output }
+makeLenses ''State
+
+handleRequest :: Request -> DisplayM State ()
+handleRequest r
+  | Just (WLOutput.ReqRelease o) <- fromRequest r = do outputs %= M.delete o
+                                                       destroyResource o
+  | Just (BindOutput o)          <- fromRequest r = do outputs %= M.insert o Output
+                                                       sendEvent o $ WLOutput.EvGeometry geometry
+                                                       sendEvent o $ WLOutput.EvDone
+                                                       flushEvents
+  | otherwise                                     = pure ()
+
+main :: IO ()
+main = void $ withDisplay (State M.empty) $ do
+  socket <- bindSocket
+  liftIO $ putStrLn $ "Listening on socket: " ++ socket
+  output <- registerGlobal BindOutput
+  processRequests handleRequest
+  unregisterGlobal output