From 749e96d23a6a71139ef84322708e6b1338072b7d Mon Sep 17 00:00:00 2001 From: Hannes Schulze Date: Fri, 2 Aug 2024 17:44:25 +0200 Subject: initial commit --- .gitignore | 1 + cabal.project | 3 ++ flake.lock | 115 ++++++++++++++++++++++++++++++++++++++++ flake.nix | 44 +++++++++++++++ hie.yaml | 20 +++++++ highway/Main.hs | 48 +++++++++++++++++ highway/highway.cabal | 20 +++++++ protocols/.gitignore | 3 ++ protocols/cabal.project | 1 + protocols/codegen/Main.hs | 2 + protocols/codegen/codegen.cabal | 14 +++++ wayland/Wayland/Server.hs | 77 +++++++++++++++++++++++++++ wayland/wayland.cabal | 17 ++++++ 13 files changed, 365 insertions(+) create mode 100644 .gitignore create mode 100644 cabal.project create mode 100644 flake.lock create mode 100644 flake.nix create mode 100644 hie.yaml create mode 100644 highway/Main.hs create mode 100644 highway/highway.cabal create mode 100644 protocols/.gitignore create mode 100644 protocols/cabal.project create mode 100644 protocols/codegen/Main.hs create mode 100644 protocols/codegen/codegen.cabal create mode 100644 wayland/Wayland/Server.hs create mode 100644 wayland/wayland.cabal 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 -- cgit v1.3.1