Improve pulldowns & status display

main.janet

@@ -24,7 +24,20 @@
 (def registry @{})
 (def wl-outputs @{})
 
-(def wm @{:outputs @[] :seats @[] :windows @[] :render-order @[] :inputs @[] :pulldowns @{}})
+(def wm @{:outputs @[] :seats @[] :windows @[] :render-order @[] :inputs @[] :pulldowns @{} :callbacks @{}})
+(defn callback [id & args]
+  (each cb (get-in wm [:callbacks id] {}) (cb ;args)))
+
+(defmacro register-callback [id args & body]
+  (def keysym (gensym))
+  ~(do
+    (def ,keysym [:callbacks ,id @{}])
+    (defn clear [] (put-in wm ,keysym nil))
+    (put-in wm ,keysym (fn ,args ,;body))
+    clear))
+
+(defmacro register-callback-once [id args & body]
+  '(register-callback ,id ,args ,;body '(clear)))
 
 (def tags-main [:a :r :s :t :n :e :i :o])
 (def tags-offload [:comma :period])
@@ -146,40 +159,15 @@
     (each k keys
       (put obj k nil))))
 
-(defn output/set-main-tag [output tag]
-  (map |(when (= ($ :tag-main) tag) (put $ :tag-main nil)) (wm :outputs))
-  (put output :tag-main tag)
-  (put output :tag-offload nil))
-
-(defn output/toggle-other-tag [output tag]
-  (if (has-value? (output :tags-other) tag)
-    (do
-      (put output :tags-other (filter |(not (= $ tag)) (output :tags-other)))
-      false)
-    (do
-      (map (fn [output] (update output :tags-other (fn [tags] (filter |(not (= $ tag)) tags)))) (wm :outputs))
-      (update output :tags-other |[;$ tag])
-      true)))
-
-(defn output/toggle-offload-tag [output tag]
-  (put output :tag-offload (if (= (output :tag-offload) tag) nil tag)))
-
-(defn output/ensure-main-tag [output]
-  (when (not (output :tag-main))
-    (def available (->> tags-main
-                        (reverse)
-                        (filter (fn [tag] (not (some |(= tag ($ :tag-main)) (wm :outputs)))))))
-    (def tag (or
-               (find (fn [tag] (not (some |(= ($ :tag) tag) (wm :windows)))) available)
-               (first available)))
-    (put output :tag-main tag)))
-
 (defn output/manage [output]
-  (put output :tags [(output :tag-main)
+  (def new-tags [(output :tag-main)
                  ;(output :tags-other)
                  ;(if (output :tag-offload)
                     [[(output :tag-main) (output :tag-offload)]]
-                        [])]))
+                    [])])
+  (unless (= new-tags (output :tags))
+    (put output :tags new-tags)
+    (callback [:output-new-tags (get-in output [:wl-output :name])] new-tags)))
 
 (defn window/enter-fullscreen [window &opt inform]
   (put window :fullscreen true)
@@ -353,6 +341,38 @@
       (window/propose-dimensions window w h)
       (:place-top (window :node)))))
 
+(defn output/set-main-tag [output tag]
+  (map |(when (= ($ :tag-main) tag) (put $ :tag-main nil)) (wm :outputs))
+  (put output :tag-main tag)
+  (put output :tag-offload nil))
+
+(defn output/toggle-other-tag [output tag]
+  (if (has-value? (output :tags-other) tag)
+    (do
+      (put output :tags-other (filter |(not (= $ tag)) (output :tags-other)))
+      false)
+    (do
+      (map (fn [output] (update output :tags-other (fn [tags] (filter |(not (= $ tag)) tags)))) (wm :outputs))
+      (update output :tags-other |[;$ tag])
+      (when-let [window (find |(= ($ :tag) tag) (wm :windows))]
+        (put window :output output)
+        (seat/focus (first (wm :seats)) window))
+      true)))
+
+(defn output/toggle-offload-tag [output tag]
+  (put output :tag-offload (if (= (output :tag-offload) tag) nil tag)))
+
+(defn output/ensure-main-tag [output]
+  (when (not (output :tag-main))
+    (def available (->> tags-main
+                        (reverse)
+                        (filter (fn [tag] (not (some |(= tag ($ :tag-main)) (wm :outputs)))))))
+    (def tag (or
+               (find (fn [tag] (not (some |(= ($ :tag) tag) (wm :windows)))) available)
+               (first available)))
+    (put output :tag-main tag)))
+
+
 (defn wm/manage []
   (set (wm :render-order) (filter |(not ($ :closed)) (wm :render-order)))
   (defn close [o] (not (when (or (o :removed) (o :closed)) (:destroy (o :obj)) true)))
@@ -360,8 +380,6 @@
   (set (wm :windows) (filter close (wm :windows)))
   (set (wm :seats) (filter close (wm :seats)))
 
-  (defn output/set-main-tag [output tag]
-    (map |(if (= ($ :tag-main)) tag) (wm :outputs)))
   (map seat/manage (wm :seats))
   (map output/ensure-main-tag (wm :outputs))
   (map output/manage (wm :outputs))
@@ -376,6 +394,7 @@
 
   (:manage-finish (registry "river_window_manager_v1")))
 
+
 (defn rgb-to-u32-rgba [rgb]
   [(* (band 0xff (brushift rgb 16)) (/ 0xffff_ffff 0xff))
    (* (band 0xff (brushift rgb 8)) (/ 0xffff_ffff 0xff))
@@ -420,9 +439,8 @@
 (defn mark-dirty []
   (:manage-dirty (registry "river_window_manager_v1")))
 
-(defn status-display []
+(defn status-display [output]
-  (def seat (first (wm :seats)))
+  (def output (find |(= (get-in $ [:wl-output :name]) output) (wm :outputs)))
-  (def output (seat :focused-output))
   (string
     ":" (output :tag-main)
     (case (output :tag-offload)
@@ -432,6 +450,12 @@
     " "
     (string/join (map |(string ":" $) (filter keyword? (output :tags-other))))))
 
+(defn status-watcher [output]
+  (def out (dyn *out*))
+  (def clear (register-callback [:output-new-tags output] [tags] (with-dyns [*out* out] (print (status-display output)))))
+  (print (status-display output))
+  (defer (clear) (forever (ev/sleep 0.1))))
+
 
 (defn action/target-in [obj list dir]
   (let [i (or (index-of obj list) -1)]
@@ -521,20 +545,25 @@
     (def appid (window :app-id))
     (put window :tag [:pulldown appid])
     (window/set-float window true)
-    (when-let [w ((wm :pulldowns) appid)]
+    (when-let [w ((wm :pulldowns) appid)
+               open (not (w :closed))]
       (:close (w :obj)))
     (put (wm :pulldowns) appid window)))
 
 (defn action/pulldown [appid command]
   (fn [seat binding]
-    (when (output/toggle-other-tag (seat :focused-output) [:pulldown appid])
+    (let [output (seat :focused-output)
-      (if-let [window (get-in wm [:pulldowns appid])]
+          tag [:pulldown appid]
-        (if-not (window :closed)
+          has-tag (has-value? (output :tags-other) tag)
-          (do
+          window (get-in wm [:pulldowns appid])
-            (put window :output (seat :focused-output))
+          closed (when window (window :closed))
-            (seat/focus seat window))
+          has-window (and window (not closed))
-          (spawn command))
+          toggle-tag (delay (output/toggle-other-tag output tag))
-        (spawn command)))))
+          open (delay (spawn command))]
+      (cond
+        has-window (toggle-tag)
+        has-tag (open)
+        (do (open) (toggle-tag))))))
 
 
 (defn locked-screen []
@@ -608,8 +637,14 @@
   (spawn "io.github.alainm23.planify"))
 
 # TODO: layout flexibility
-
+# TODO: fix waybar complaining about <
-# TODO: reload with repl?
+# TODO: fullscreen oddities with games: debug (warframe, novadrift, portal)
+# TODO: firefox focus weirdness
+# TODO: double fullscreen
+# TODO: floating windows (WF launcher, discord launch screen, pinentry, ...)
+# TODO: swaylock hibernate acquire
+# TODO: actually do idle lock
+# TODO: mouse warp on switch output
 
 (defn configure-keymap []
   (def ctx (xkbcommon/context/new))

repl.janet

@@ -3,19 +3,23 @@
 
 (defn run-commands [sock args]
   (with [stream (net/connect :unix sock)]
-    (def recv (msg/make-recv stream))
+    (def recv- (msg/make-recv stream))
     (def send (msg/make-send stream))
-    (send (string/format "\xFF%j" {:auto-flush false :name ""}))
+    (send (string/format "\xFF%j" {:auto-flush true :name ""}))
+    (defn recv []
+      (def ms (recv-))
+      (case (ms 0)
+        nil ms
+        0xFF (do
+          (prin (slice ms 1))
+          (flush)
+          (recv))
+        0xFE (slice ms 1))
+        ms)
     (def prompt (recv))
     (each arg args
-      (send (string "\xFF" arg))
+      (send arg)
-      (def [ok val] (-> (recv)
+      (loop [:until (= prompt (recv))]))))
-                        (parse)))
-      (if (string? val)
-        (print val)
-        (pp val))
-      (unless ok
-        (os/exit 1)))))
 
 (defn main [exe & args]
   (def sock (string (os/getenv "XDG_RUNTIME_DIR") "/censtablo-" (os/getenv "WAYLAND_DISPLAY")))