diff --git a/quasar-wayland/quasar-wayland.cabal b/quasar-wayland/quasar-wayland.cabal index c9f8578..098dd8f 100644 --- a/quasar-wayland/quasar-wayland.cabal +++ b/quasar-wayland/quasar-wayland.cabal @@ -54,6 +54,7 @@ library exposed-modules: Quasar.Wayland.Client Quasar.Wayland.Client.JuicyPixels + Quasar.Wayland.Client.Output Quasar.Wayland.Client.Registry Quasar.Wayland.Client.ShmBuffer Quasar.Wayland.Client.Socket diff --git a/quasar-wayland/src/Quasar/Wayland/Client/Output.hs b/quasar-wayland/src/Quasar/Wayland/Client/Output.hs new file mode 100644 index 0000000..26df95f --- /dev/null +++ b/quasar-wayland/src/Quasar/Wayland/Client/Output.hs @@ -0,0 +1,53 @@ +module Quasar.Wayland.Client.Output ( + Output(..), + getOutputs, +) where + +import Quasar.Observable.Core +import Quasar.Observable.List (ObservableList) +import Quasar.Observable.List qualified as ObservableList +import Quasar.Observable.ObservableVar +import Quasar.Prelude +import Quasar.Wayland.Client +import Quasar.Wayland.Client.Registry +import Quasar.Wayland.Protocol +import Quasar.Wayland.Protocol.Generated + +data Output = Output { + wlOutput :: Object 'Client Interface_wl_output, + name :: Observable NoLoad '[] String, + description :: Observable NoLoad '[] String +} + +getOutputs :: WaylandClient -> STMc NoRetry '[] (ObservableList NoLoad '[] Output) +getOutputs client = getClientComponent (newOutputList client) client + +newOutputList :: WaylandClient -> STMc NoRetry '[] (ObservableList NoLoad '[] Output) +newOutputList client = ObservableList.cache (traverseGlobals client.registry 4 initializeOutput finalizeOutput) + +initializeOutput :: + NewObject 'Client Interface_wl_output -> + STMc NoRetry '[] Output +initializeOutput wlOutput = do + -- TODO abort if version == 1, mode handling is broken + + nameVar <- newObservableVar "" + descriptionVar <- newObservableVar "" + + setEventHandler wlOutput EventHandler_wl_output { + geometry = \_x _y _physical_width _physical_height _subpixel _make _model _transform -> pure (), + mode = \_flags _width _height _refresh -> pure (), + done = pure (), + scale = \_factor -> pure (), + name = \name -> writeObservableVar nameVar (toString name), + description = \description -> writeObservableVar nameVar (toString description) + } + + pure Output { + wlOutput, + name = toObservable nameVar, + description = toObservable descriptionVar + } + +finalizeOutput :: Output -> STMc NoRetry '[] () +finalizeOutput output = tryCall output.wlOutput.release