summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore1
-rw-r--r--cabal.project3
-rw-r--r--flake.lock115
-rw-r--r--flake.nix44
-rw-r--r--hie.yaml20
-rw-r--r--highway/Main.hs48
-rw-r--r--highway/highway.cabal20
-rw-r--r--protocols/.gitignore3
-rw-r--r--protocols/cabal.project1
-rw-r--r--protocols/codegen/Main.hs2
-rw-r--r--protocols/codegen/codegen.cabal14
-rw-r--r--wayland/Wayland/Server.hs77
-rw-r--r--wayland/wayland.cabal17
13 files changed, 365 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..56ad05d
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+dist*
diff --git a/cabal.project b/cabal.project
new file mode 100644
index 0000000..0c90837
--- /dev/null
+++ b/cabal.project
@@ -0,0 +1,3 @@
+packages: wayland/wayland.cabal
+ protocols/protocols.cabal
+ highway/highway.cabal
diff --git a/flake.lock b/flake.lock
new file mode 100644
index 0000000..4dbcc8e
--- /dev/null
+++ b/flake.lock
@@ -0,0 +1,115 @@
+{
+ "nodes": {
+ "flake-compat": {
+ "locked": {
+ "lastModified": 1688025799,
+ "narHash": "sha256-ktpB4dRtnksm9F5WawoIkEneh1nrEvuxb5lJFt1iOyw=",
+ "owner": "nix-community",
+ "repo": "flake-compat",
+ "rev": "8bf105319d44f6b9f0d764efa4fdef9f1cc9ba1c",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-community",
+ "repo": "flake-compat",
+ "type": "github"
+ }
+ },
+ "flake-utils": {
+ "inputs": {
+ "systems": "systems"
+ },
+ "locked": {
+ "lastModified": 1710146030,
+ "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "nixos-apple-silicon": {
+ "inputs": {
+ "flake-compat": "flake-compat",
+ "nixpkgs": [
+ "nixpkgs"
+ ],
+ "rust-overlay": "rust-overlay"
+ },
+ "locked": {
+ "lastModified": 1722469787,
+ "narHash": "sha256-P20oAmbgXHl1E77TXPXiAj1Ntycc1mf7fZMI7X13VYw=",
+ "owner": "tpwrules",
+ "repo": "nixos-apple-silicon",
+ "rev": "8a665fee82901878edaeb8ee120296a979db2dd2",
+ "type": "github"
+ },
+ "original": {
+ "owner": "tpwrules",
+ "repo": "nixos-apple-silicon",
+ "type": "github"
+ }
+ },
+ "nixpkgs": {
+ "locked": {
+ "lastModified": 1722185531,
+ "narHash": "sha256-veKR07psFoJjINLC8RK4DiLniGGMgF3QMlS4tb74S6k=",
+ "owner": "nixos",
+ "repo": "nixpkgs",
+ "rev": "52ec9ac3b12395ad677e8b62106f0b98c1f8569d",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nixos",
+ "ref": "nixos-unstable",
+ "repo": "nixpkgs",
+ "type": "github"
+ }
+ },
+ "root": {
+ "inputs": {
+ "flake-utils": "flake-utils",
+ "nixos-apple-silicon": "nixos-apple-silicon",
+ "nixpkgs": "nixpkgs"
+ }
+ },
+ "rust-overlay": {
+ "flake": false,
+ "locked": {
+ "lastModified": 1686795910,
+ "narHash": "sha256-jDa40qRZ0GRQtP9EMZdf+uCbvzuLnJglTUI2JoHfWDc=",
+ "owner": "oxalica",
+ "repo": "rust-overlay",
+ "rev": "5c2b97c0a9bc5217fc3dfb1555aae0fb756d99f9",
+ "type": "github"
+ },
+ "original": {
+ "owner": "oxalica",
+ "repo": "rust-overlay",
+ "type": "github"
+ }
+ },
+ "systems": {
+ "locked": {
+ "lastModified": 1681028828,
+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+ "owner": "nix-systems",
+ "repo": "default",
+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-systems",
+ "repo": "default",
+ "type": "github"
+ }
+ }
+ },
+ "root": "root",
+ "version": 7
+}
diff --git a/flake.nix b/flake.nix
new file mode 100644
index 0000000..dcc0b7a
--- /dev/null
+++ b/flake.nix
@@ -0,0 +1,44 @@
+{
+ description = "A purely functional wayland compositor.";
+
+ inputs = {
+ nixpkgs = {
+ url = "github:nixos/nixpkgs/nixos-unstable";
+ };
+ flake-utils = {
+ url = "github:numtide/flake-utils";
+ };
+ nixos-apple-silicon = {
+ url = "github:tpwrules/nixos-apple-silicon";
+ inputs.nixpkgs.follows = "nixpkgs";
+ };
+ };
+
+ outputs = { self, nixpkgs, flake-utils, nixos-apple-silicon }:
+ flake-utils.lib.eachDefaultSystem (system:
+ let
+ shell = name: overlays:
+ let
+ pkgs = import nixpkgs {
+ inherit system overlays;
+ };
+ haskell = pkgs.haskellPackages.ghcWithPackages (p:
+ with p; [ microlens microlens-mtl microlens-th haskell-language-server ]);
+ in
+ pkgs.mkShell {
+ inherit name;
+ packages = [ haskell pkgs.pkg-config pkgs.wayland pkgs.cabal-install ];
+ hardeningDisable = [ "fortify" ];
+ };
+ in
+ {
+ devShells = {
+ default = shell "highway" [];
+ asahi = shell "highway-asahi" [
+ (final: prev: {
+ mesa = nixos-apple-silicon.packages.${system}.mesa-asahi-edge;
+ })
+ ];
+ };
+ });
+}
diff --git a/hie.yaml b/hie.yaml
new file mode 100644
index 0000000..857f8dc
--- /dev/null
+++ b/hie.yaml
@@ -0,0 +1,20 @@
+cradle:
+ multi:
+ - path: "protocols/codegen"
+ config:
+ cradle:
+ cabal:
+ cabalProject: "protocols/cabal.project"
+ components:
+ - path: "protocols/codegen"
+ component: "highway-protocols-codegen:exe:codegen"
+ - path: "."
+ config:
+ cradle:
+ cabal:
+ - path: "highway"
+ component: "highway:exe:highway"
+ - path: "protocols"
+ component: "lib:highway-protocols"
+ - path: "wayland"
+ component: "lib:highway-wayland"
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
diff --git a/protocols/.gitignore b/protocols/.gitignore
new file mode 100644
index 0000000..d6ca1ed
--- /dev/null
+++ b/protocols/.gitignore
@@ -0,0 +1,3 @@
+# generated code
+protocols.cabal
+Wayland
diff --git a/protocols/cabal.project b/protocols/cabal.project
new file mode 100644
index 0000000..7c1c60c
--- /dev/null
+++ b/protocols/cabal.project
@@ -0,0 +1 @@
+packages: codegen/codegen.cabal
diff --git a/protocols/codegen/Main.hs b/protocols/codegen/Main.hs
new file mode 100644
index 0000000..d3230a6
--- /dev/null
+++ b/protocols/codegen/Main.hs
@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Generating code"
diff --git a/protocols/codegen/codegen.cabal b/protocols/codegen/codegen.cabal
new file mode 100644
index 0000000..534f007
--- /dev/null
+++ b/protocols/codegen/codegen.cabal
@@ -0,0 +1,14 @@
+cabal-version: 3.0
+name: highway-protocols-codegen
+version: 1.0.0
+synopsis: Code generation for Wayland protocols.
+build-type: Simple
+
+common warnings
+ ghc-options: -Wall
+
+executable codegen
+ import: warnings
+ main-is: Main.hs
+ build-depends: base ^>=4.18.2.1
+ default-language: Haskell2010
diff --git a/wayland/Wayland/Server.hs b/wayland/Wayland/Server.hs
new file mode 100644
index 0000000..9162d5e
--- /dev/null
+++ b/wayland/Wayland/Server.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Wayland.Server
+ ( Request(..)
+ , ObjectID
+ , Global
+ , DisplayM(..)
+ , Resource(..)
+ , fromRequest
+ , withDisplay
+ , bindSocket
+ , processRequests
+ , flushEvents
+ , sendEvent
+ , destroyResource
+ , registerGlobal
+ , unregisterGlobal
+ ) where
+
+import Data.Typeable (Typeable, cast)
+import Data.Kind (Type)
+import Control.Monad.State.Strict (StateT, MonadState(..), MonadIO(..))
+import Lens.Micro.Mtl.Internal (Zoom(..), Zoomed)
+
+data DisplayState
+
+data Global
+
+newtype ObjectID = ObjectID String
+ deriving (Show, Eq, Ord)
+
+class Resource r where
+ type ResourceRequest r :: Type
+ type ResourceEvent r :: Type
+ objectID :: r -> ObjectID
+
+data Request = forall a. Typeable a => Request a
+
+newtype DisplayM s a = DisplayM { runDisplayM :: StateT s (StateT DisplayState IO) a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadState s)
+
+type instance Zoomed (DisplayM s) = Zoomed (StateT s (StateT DisplayState IO))
+
+instance Zoom (DisplayM s) (DisplayM t) s t where
+ zoom l (DisplayM m) = DisplayM (zoom l m)
+
+fromRequest :: Typeable a => Request -> Maybe a
+fromRequest (Request x) = cast x
+
+withDisplay :: s -> DisplayM s a -> IO (s, a)
+withDisplay _ _ = undefined
+
+bindSocket :: DisplayM s String
+bindSocket = undefined
+
+processRequests :: (Request -> DisplayM s ()) -> DisplayM s ()
+processRequests _ = undefined
+
+sendEvent :: Resource r => r -> ResourceEvent r -> DisplayM s ()
+sendEvent _ _ = undefined
+
+flushEvents :: DisplayM s ()
+flushEvents = undefined
+
+destroyResource :: Resource r => r -> DisplayM s ()
+destroyResource _ = undefined
+
+registerGlobal :: Resource r => Typeable req => (r -> req) -> DisplayM s Global
+registerGlobal _ = undefined
+
+unregisterGlobal :: Global -> DisplayM s ()
+unregisterGlobal _ = undefined
diff --git a/wayland/wayland.cabal b/wayland/wayland.cabal
new file mode 100644
index 0000000..b34d9a0
--- /dev/null
+++ b/wayland/wayland.cabal
@@ -0,0 +1,17 @@
+cabal-version: 3.0
+name: highway-wayland
+version: 1.0.0
+synopsis: Low-level API for implementing the Wayland protocol.
+build-type: Simple
+
+common warnings
+ ghc-options: -Wall
+
+library
+ import: warnings
+ build-depends: base ^>=4.18.2.1,
+ mtl,
+ microlens,
+ microlens-mtl
+ default-language: Haskell2010
+ exposed-modules: Wayland.Server
generated by cgit v1.3.1 (git 2.54.0) at 2026-11-10 10:49:03 +0000