2 files changed, 68 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
diff --git a/highway/highway.cabal b/highway/highway.cabal
new file mode 100644
index 0000000..72b1c40
--- /dev/null
+++ b/highway/highway.cabal
@@ -0,0 +1,20 @@
+cabal-version:      3.0
+name:               highway
+version:            1.0.0
+synopsis:           A purely functional wayland compositor.
+build-type:         Simple
+
+common warnings
+    ghc-options: -Wall
+
+executable highway
+    import:           warnings
+    main-is:          Main.hs
+    build-depends:    base ^>=4.18.2.1,
+                      microlens-th,
+                      microlens-mtl,
+                      mtl,
+                      containers,
+                      highway-wayland,
+                      highway-protocols
+    default-language: Haskell2010