(local {: Gio
: GLib
: GObject
: Gtk
: GdkPixbuf
: Gdk
: Pango}
(require :lgi))
(local {: List
: stringx
: tablex
}
((require :pl.import_into)))
(local dbus (require :dbus_proxy))
(local lfs (require :lfs))
(local inifile (require :inifile))
(local posix (require :posix))
(local ICON_SIZE 64)
(local CSS "
* {
color: rgb(255, 255, 255);
text-shadow:
0px 1px rgba(0, 0, 0, 255)
, 1px 0px rgba(0, 0, 0, 255)
, 0px -1px rgba(0, 0, 0, 255)
, -1px 0px rgba(0, 0, 0, 255)
, 1px 1px rgba(0, 0, 0, 255)
, 1px -1px rgba(0, 0, 0, 255)
, -1px 1px rgba(0, 0, 0, 255)
, -1px -1px rgba(0, 0, 0, 255)
;
}
button.appbutton {
padding: 0px;
}
#toplevel {
background-color: rgba(0, 0, 0, 0.6);
}
")
(local dbus-service-attrs
{
:bus dbus.Bus.SESSION
:name "net.telent.saturn"
:interface "net.telent.saturn"
:path "/net/telent/saturn"
})
(local bus (dbus.Proxy:new
{
:bus dbus.Bus.SESSION
:name "org.freedesktop.DBus"
:interface "org.freedesktop.DBus"
:path "/org/freedesktop/DBus"
}))
(local interface-info
(let [xml
"<node>
<interface name='net.telent.saturn'>
<method name='SetVisible'>
<arg type='b' name='visible' direction='in'/>
<doc:doc><doc:description>
Switch visibility of launcher window
</doc:description></doc:doc>
</method>
<method name='ToggleVisible'>
<doc:doc><doc:description>
Toggle launcher window visible/invisible
</doc:description></doc:doc>
</method>
<property name='Visible' type='b' access='read'>
</property>
</interface>
</node>"
node-info (Gio.DBusNodeInfo.new_for_xml xml)]
(. node-info.interfaces 1)))
;; these values don't seem to be available through introspection
(local DBUS_NAME_FLAG_DO_NOT_QUEUE 4)
(local DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER 1)
(local DBUS_REQUEST_NAME_REPLY_IN_QUEUE 2)
(local DBUS_REQUEST_NAME_REPLY_EXISTS 3)
(local DBUS_REQUEST_NAME_REPLY_ALREADY_OWNER 4)
(let [ret (bus:RequestName dbus-service-attrs.name
DBUS_NAME_FLAG_DO_NOT_QUEUE)]
(match ret
DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER
true
DBUS_REQUEST_NAME_REPLY_ALREADY_OWNER
true
DBUS_REQUEST_NAME_REPLY_IN_QUEUE
(error "unexpected DBUS_REQUEST_NAME_REPLY_IN_QUEUE")
DBUS_REQUEST_NAME_REPLY_EXISTS
;; Show the currently running instance
(let [saturn (dbus.Proxy:new dbus-service-attrs)]
(saturn:SetVisible true)
(os.exit 0))))
(local path {
:absolute? (fn [str] (= (str:sub 1 1) "/"))
:concat (fn [...] (table.concat [...] "/"))
})
(local search-path {
:concat (fn [...] (table.concat [...] ":"))
})
(local icon-theme (Gtk.IconTheme.get_default))
;; Use the declared CSS for this app
(let [style_provider (Gtk.CssProvider)]
(style_provider:load_from_data CSS)
(Gtk.StyleContext.add_provider_for_screen
(Gdk.Screen.get_default)
style_provider
Gtk.STYLE_PROVIDER_PRIORITY_APPLICATION
))
(local window (Gtk.Window {
:title "Saturn V"
:name "toplevel"
:default_width 720
:default_height 800
:on_destroy Gtk.main_quit
}))
;; Using RGBA visual for semi-transparent backgrounds
;; Requires compositing (e.g. a compositor on X11)
(let [screen (window:get_screen)
visual (screen:get_rgba_visual)]
(window:set_visual visual))
(fn find-icon [name]
(var found false)
(if (path.absolute? name)
;; From a direct path
(set found (GdkPixbuf.Pixbuf.new_from_file_at_size name ICON_SIZE ICON_SIZE))
;; From icon theme
(let [sizes (icon-theme:get_icon_sizes name)]
;; Uses a list of "safe fallback" values
;; Try the desired size first
(each [_ res (pairs [ICON_SIZE 128 64 48]) :until found]
(set found
(-?> (icon-theme:load_icon
name res
(+ Gtk.IconLookupFlags.FORCE_SVG Gtk.IconLookupFlags.USE_BUILTIN))
(: :scale_simple ICON_SIZE ICON_SIZE GdkPixbuf.InterpType.BILINEAR))))
))
(Gtk.Image.new_from_pixbuf found))
(fn read-desktop-file [f]
(let [parsed (inifile.parse f)
vals (. parsed "Desktop Entry")]
(tset vals "IconImage"
(find-icon (or vals.Icon "application-x-executable")))
(tset vals "ID" (f:sub 0 -9))
vals))
(fn current-user-home []
"Returns current user's home directory."
(-> (posix.unistd.getuid)
(posix.pwd.getpwuid)
(. :pw_dir)))
(fn xdg-data-home []
"Provides XDG_DATA_HOME or its default fallback value"
(or (os.getenv "XDG_DATA_HOME")
(path.concat (current-user-home) ".local/share/")))
(fn xdg-data-dirs []
"Provides all data-dirs as a List. Most important first."
;; Expected to be used with gmatch as a generator.
(let [dirs (List)]
(dirs:append (xdg-data-home))
(dirs:extend (stringx.split (os.getenv "XDG_DATA_DIRS") ":"))
dirs
))
(fn all-apps []
;; Each desktop entry representing an application is identified
;; by its desktop file ID, which is based on its filename.
;; — https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-latest.html#desktop-file-id
"Provides apps in a List, sorted by name"
(var apps-table {})
;; Reversing the data dirs gives priority to the first elements.
;; This means conflicting `.desktop` files (or: desktop file ID) are given
;; priority to the first elements by "simply" reading it last.
(each [path (List.iter (List.reverse (xdg-data-dirs)))]
(let [apps-dir (.. path "/applications/")]
(when (lfs.attributes apps-dir)
(each [f (lfs.dir apps-dir)]
(when (= (f:sub -8) ".desktop")
(let [attrs (read-desktop-file (.. apps-dir f))]
(when (not attrs.NoDisplay)
(tset apps-table attrs.ID attrs))))))))
;; We have a table indexed by IDs, we don't care about the indexing.
;; Make a List and sort it by name.
(List.sort (List (tablex.values apps-table))
(fn [a b] (< (string.upper a.Name) (string.upper b.Name)))))
;; Exec entries in desktop files may contain %u %f and other characters
;; in which the launcher is supposed to interpolate filenames/urls etc.
;; We don't afford the user any way to pick filenames, but we do need
;; to remove the placeholders.
(fn parse-percents [str]
(str:gsub "%%(.)" (fn [c] (if (= c "%") "%" ""))))
(fn spawn-async [vec]
(let [pid (posix.unistd.fork)]
(if (> pid 0) true
(< pid 0) (assert (= "can't fork" nil))
(do
(for [f 3 255] (posix.unistd.close f))
(posix.execp "/usr/bin/env" vec)))))
(fn launch [app]
;; FIXME check app.DBusActivatable and do DBus launch if true
(let [cmd (parse-percents app.Exec)]
(if app.Terminal
(spawn-async ["kitty" cmd])
(spawn-async ["sh" "-c" cmd]))
(window:hide)))
(fn button-for [app]
(doto (Gtk.Button
{
:image-position Gtk.PositionType.TOP
:relief Gtk.ReliefStyle.NONE
:on_clicked #(launch app)
})
(-> (: :get_style_context) (: :add_class "appbutton"))
(: :add
(doto (Gtk.Box {:orientation Gtk.Orientation.VERTICAL})
(: :pack_start app.IconImage false false 0)
(: :pack_start
(doto
(Gtk.Label {
;; https://stackoverflow.com/questions/27462926/how-to-set-max-width-of-gtklabel-properly
:label app.Name
:justify Gtk.Justification.CENTER
:ellipsize Pango.EllipsizeMode.END
:hexpand true
})
(: :set_max_width_chars 1))
true true 0)
))))
(fn handle-dbus-method-call [conn sender path interface method params invocation]
(when (and (= path dbus-service-attrs.path)
(= interface dbus-service-attrs.interface))
(match method
"SetVisible"
(let [[value] (dbus.variant.strip params)]
(if value (window:show_all) (window:hide))
(invocation:return_value nil))
"ToggleVisible"
(let [v window.visible]
(if v (window:hide) (window:show_all))
(invocation:return_value nil)))))
(fn handle-dbus-get [conn sender path interface name]
(when (and (= path dbus-service-attrs.path)
(= interface dbus-service-attrs.interface)
(= name "Visible"))
(GLib.Variant "b" window.visible)))
(Gio.DBusConnection.register_object
bus.connection
dbus-service-attrs.path
interface-info
(GObject.Closure handle-dbus-method-call)
(GObject.Closure handle-dbus-get)
(GObject.Closure (fn [a] (print "set"))))
(let [grid (Gtk.FlowBox {
:orientation Gtk.Orientation.HORIZONTAL
:valign Gtk.Align.START
:column_spacing 2
:row_spacing 5
:homogeneous true
})
scrolled-window (Gtk.ScrolledWindow {})]
(each [app (List.iter (all-apps))]
(grid:insert (button-for app) -1))
(scrolled-window:add grid)
(window:add scrolled-window))
(window:show_all)
(Gtk:main)