init.fnl (6585B)
1 (local {: Gtk 2 : GtkLayerShell 3 : Gdk 4 : GdkPixbuf 5 : Gio 6 : GLib 7 : cairo } (require :lgi)) 8 9 (local posix (require :posix)) 10 11 (local {: view} (require :fennel)) 12 13 (local icon-theme (Gtk.IconTheme.get_default)) 14 15 (local HEIGHT 48) 16 17 (local css-provider 18 (let [p (Gtk.CssProvider)] 19 (Gtk.StyleContext.add_provider_for_screen 20 (Gdk.Screen.get_default) 21 p 22 Gtk.STYLE_PROVIDER_PRIORITY_APPLICATION) 23 p)) 24 25 (fn load-styles [pathname] 26 (let [(success err) (css-provider:load_from_path pathname)] 27 (or success 28 (print "failed to load stylesheet" err)))) 29 30 (var file-monitor nil) 31 (fn watch-stylesheet [pathname] 32 (let [f (Gio.File.new_for_path pathname) 33 (monitor err) 34 (Gio.File.monitor f Gio.FileMonitorFlags.NONE nil)] 35 (load-styles pathname) 36 (if (not monitor) (print :watch-stylesheet err)) 37 (set file-monitor monitor) 38 (doto monitor 39 (tset 40 :on_changed 41 #(load-styles (: $2 :get_path)))))) 42 43 (fn resolve [f] 44 (match (type f) 45 "string" f 46 "function" (f))) 47 48 (fn find-icon-pixbuf [name] 49 (var found nil) 50 (each [_ res (pairs [HEIGHT 128 64 48]) :until found] 51 (let [pixbuf (icon-theme:load_icon 52 name res 53 (+ Gtk.IconLookupFlags.FORCE_SVG 54 Gtk.IconLookupFlags.USE_BUILTIN))] 55 (when pixbuf 56 (set found (pixbuf:scale_simple 57 HEIGHT (* pixbuf.width (/ HEIGHT pixbuf.height)) 58 GdkPixbuf.InterpType.BILINEAR))))) 59 found) 60 61 (local found-icons {}) 62 63 (macro check-err [form] 64 `(let [(result# err#) ,form] 65 (or result# 66 (error err#)))) 67 68 (fn load-icon [name] 69 (let [pixbuf 70 (if (= (name:sub 1 1) "/") 71 ;; From a direct path 72 (check-err 73 (GdkPixbuf.Pixbuf.new_from_file_at_scale name HEIGHT -1 true)) 74 ;; From icon theme 75 (find-icon-pixbuf name))] 76 (Gtk.Image.new_from_pixbuf pixbuf))) 77 78 (fn find-icon [name] 79 (let [icon (. found-icons name)] 80 (or icon 81 (let [(icon err) (load-icon name)] 82 (if (not icon) (print err)) 83 (tset found-icons name icon) 84 icon)))) 85 86 (fn add-css-classes [widget classes] 87 (let [context (widget:get_style_context)] 88 (each [_ c (ipairs classes)] 89 (context:add_class c)))) 90 91 (fn clear-css-classes [widget] 92 (let [context (widget:get_style_context)] 93 (each [_ c (ipairs (context:list_classes))] 94 (context:remove_class c)))) 95 96 (fn indicator [{: wait-for 97 : refresh 98 : on-click}] 99 (let [button (Gtk.EventBox { })] 100 (fn update-indicator [] 101 (let [content (resolve refresh)] 102 (when content 103 (match (button:get_child) it (button:remove it)) 104 (match content 105 {:icon icon} (button:add (find-icon icon)) 106 {:text text} (button:add (Gtk.Label {:label text}))) 107 (clear-css-classes button) 108 (add-css-classes button ["indicator"]) 109 (match content 110 {:classes classes} (add-css-classes button classes)) 111 (button:show_all)))) 112 (update-indicator) 113 114 { 115 : button 116 :update update-indicator 117 :inputs (or wait-for.input []) 118 :interval wait-for.interval 119 })) 120 121 (fn make-layer-shell [window layer exclusive? anchors] 122 (let [s GtkLayerShell] 123 (s.init_for_window window) 124 (s.set_layer window (. { 125 :top GtkLayerShell.Layer.TOP 126 } 127 layer)) 128 (if exclusive? (s.auto_exclusive_zone_enable window)) 129 130 (each [edge margin (pairs anchors)] 131 (let [edge (. {:top GtkLayerShell.Edge.TOP 132 :bottom GtkLayerShell.Edge.BOTTOM 133 :left GtkLayerShell.Edge.LEFT 134 :right GtkLayerShell.Edge.RIGHT} 135 edge)] 136 (GtkLayerShell.set_margin window edge margin) 137 (GtkLayerShell.set_anchor window edge 1))))) 138 139 (local bars []) 140 141 (fn bar [{: anchor : orientation : indicators 142 : gravity 143 : classes }] 144 (let [window (Gtk.Window {} ) 145 orientation (match orientation 146 :vertical Gtk.Orientation.VERTICAL 147 :horizontal Gtk.Orientation.HORIZONTAL) 148 box (Gtk.Box { :orientation orientation})] 149 (doto box 150 (add-css-classes ["bar"]) 151 (add-css-classes (or classes []))) 152 153 (if (= gravity :end) 154 (box:pack_start (Gtk.EventBox) true true 0)) 155 156 (table.insert bars { : window : anchor : indicators }) 157 (each [_ i (ipairs indicators)] 158 (box:pack_start i.button false false 0)) 159 (window:add box))) 160 161 (fn gsource-for-file-input [file cb] 162 (let [fd file.fileno] 163 (doto (GLib.unix_fd_source_new fd GLib.IOCondition.IN) 164 (: :set_callback cb)))) 165 166 (fn ready-to-update? [indicator now update-times] 167 (if indicator.interval 168 (> now (or (. update-times indicator) 0)))) 169 170 (fn hcf [a b] 171 (let [remainder (% a b)] 172 (if (= remainder 0) 173 b 174 (hcf b remainder)))) 175 176 (assert (= (hcf 198 360) 18)) 177 (assert (= (hcf 10 15) 5)) 178 179 (fn minimum-interval [intervals] 180 (accumulate [min (. intervals 1) 181 _ interval (ipairs intervals)] 182 (hcf min interval))) 183 184 (assert (= (minimum-interval [ 350 1000 5000 ]) 50)) 185 186 (fn run [] 187 (var intervals []) 188 (each [_ bar (ipairs bars)] 189 (each [_ indicator (ipairs bar.indicators)] 190 (if indicator.interval 191 (table.insert intervals indicator.interval)) 192 (each [_ file (ipairs indicator.inputs)] 193 (GLib.Source.attach 194 (gsource-for-file-input 195 file 196 #(or (indicator:update) true)))))) 197 (let [update-times {} 198 interval (minimum-interval intervals)] 199 (when (< interval 100) 200 (print (.. "required refresh interval is " interval "ms"))) 201 (GLib.timeout_add 202 0 203 (minimum-interval intervals) 204 (fn [] 205 (let [now (/ (GLib.get_monotonic_time) 1000)] 206 (each [_ bar (ipairs bars)] 207 (each [_ indicator (ipairs bar.indicators)] 208 (when (ready-to-update? indicator now update-times) 209 (indicator:update) 210 (tset update-times indicator (+ now indicator.interval)))))) 211 true))) 212 (each [_ b (ipairs bars)] 213 (make-layer-shell b.window :top true 214 (collect [_ edge (ipairs b.anchor)] 215 edge 0)) 216 (b.window:show_all)) 217 (Gtk.main)) 218 219 { 220 : bar 221 : indicator 222 : run 223 :stylesheet watch-stylesheet 224 : file-monitor ;don't let this get GCed 225 }