;; This file is part of mowedline.
;; Copyright (C) 2011-2015 John J. Foerch
;;
;; mowedline is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; mowedline is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with mowedline. If not, see .
(include "llog")
(module mowedline
*
(import chicken scheme)
(use srfi-1
srfi-4 ;; homogeneous numeric vectors
srfi-13 ;; string
srfi-14 ;; character sets
srfi-18 ;; threads
srfi-69 ;; hash tables
coops
data-structures
(prefix dbus dbus:)
extras
filepath
(prefix imperative-command-line-a icla:)
list-utils
mailbox
miscmacros
ports
posix
xft
(except xlib make-xrectangle
xrectangle-x xrectangle-y
xrectangle-width xrectangle-height)
(prefix xlib-utils xu:)
xtypes)
(import llog)
(include "version")
(include "utils")
;;;
;;; Globals
;;;
(define current-xcontext (make-parameter #f))
(define xcontexts (list))
(define *widgets* (make-hash-table test: equal?))
(define *default-widgets* (list))
(define *command-line-windows* (list))
(define *internal-events* (make-mailbox))
(define %quit-mowedline #f) ;; will be bound to a quit continuation
(define (quit-mowedline . _)
(%quit-mowedline #t))
(define (switch-to-desktop desktop)
(xu:switch-to-desktop (current-xcontext) desktop))
;;;
;;; Button
;;;
(define-record button
xrectangle handler)
;;;
;;; Window
;;;
(define window-background (make-parameter #f))
(define window-lower (make-parameter #t))
(define window-position (make-parameter 'top))
(define window-get-next-id
(let ((last -1))
(lambda ()
(inc! last)
last)))
(define-class ()
((id initform: (window-get-next-id))
(xcontext initform: (current-xcontext))
(position initform: (window-position))
(height initform: #f)
(width initform: #f)
(baseline initform: #f)
(margin-top initform: 0)
(margin-right initform: 0)
(margin-bottom initform: 0)
(margin-left initform: 0)
(background initform: (window-background))
(widgets initform: (list))
(fonts initform: (list))))
(define (window . args)
(receive (props widgets)
(split-properties args)
(apply make 'widgets widgets props)))
(define-method (initialize-instance (window ))
(call-next-method)
(xu:with-xcontext (slot-value window 'xcontext)
(xcontext display screen root)
(for-each (lambda (widget) (widget-set-window! widget window))
(slot-value window 'widgets))
(let* ((shei (xdisplayheight display screen))
(position (slot-value window 'position))
(width (or (slot-value window 'width)
(- (xdisplaywidth display screen)
(slot-value window 'margin-left)
(slot-value window 'margin-right))))
(height (or (slot-value window 'height)
(fold max 1 (map widget-preferred-height
(slot-value window 'widgets)))))
(window-top (case position
((bottom) (- shei (slot-value window 'margin-bottom) height))
(else (slot-value window 'margin-top))))
(xwindow (xcreatesimplewindow
display
root
(slot-value window 'margin-left)
window-top width height 0
(xblackpixel display screen)
(xwhitepixel display screen))))
(assert xwindow)
(let* ((xcontext (xu:make-xcontext xcontext window: xwindow)))
(set! (slot-value window 'xcontext) xcontext)
(set! (slot-value window 'width) width)
(set! (slot-value window 'height) height)
(set! (slot-value window 'baseline)
(fold max 1 (map widget-preferred-baseline
(slot-value window 'widgets))))
(for-each widget-init (slot-value window 'widgets))
(window-update-widget-dimensions! window)
(let* ((attr (make-xsetwindowattributes))
(background (slot-value window 'background))
(flags #f))
(cond
((eq? 'inherit background)
(set! flags (bitwise-ior CWBACKPIXMAP CWBORDERPIXEL CWOVERRIDEREDIRECT))
(set-xsetwindowattributes-background_pixmap! attr PARENTRELATIVE))
(else
(set! flags (bitwise-ior CWBACKPIXEL CWBORDERPIXEL CWOVERRIDEREDIRECT))
(set-xsetwindowattributes-background_pixel! attr (xblackpixel display screen))))
(set-xsetwindowattributes-border_pixel! attr (xblackpixel display screen))
(set-xsetwindowattributes-override_redirect! attr 1)
(xchangewindowattributes display xwindow flags attr))
;; Window Properties
;;
(xstorename display xwindow "mowedline")
(let ((p (make-xtextproperty))
(str (xu:make-text-property (get-host-name))))
(xstringlisttotextproperty str 1 p)
(xsetwmclientmachine display xwindow p))
(xu:window-property-set xcontext "_NET_WM_PID"
(xu:make-number-property (current-process-id)))
(xu:window-property-set xcontext "_NET_WM_WINDOW_TYPE"
(xu:make-atom-property xcontext "_NET_WM_TYPE_DOCK"))
(xu:window-property-set xcontext "_NET_WM_DESKTOP"
(xu:make-number-property #xffffffff))
(xu:window-property-set xcontext "_NET_WM_STATE"
(xu:make-atom-property xcontext "_NET_WM_STATE_BELOW"))
(xu:window-property-append xcontext "_NET_WM_STATE"
(xu:make-atom-property xcontext "_NET_WM_STATE_STICKY"))
(xu:window-property-append xcontext "_NET_WM_STATE"
(xu:make-atom-property xcontext "_NET_WM_STATE_SKIP_TASKBAR"))
(xu:window-property-append xcontext "_NET_WM_STATE"
(xu:make-atom-property xcontext "_NET_WM_STATE_SKIP_PAGER"))
;; Struts: left, right, top, bottom,
;; left_start_y, left_end_y, right_start_y, right_end_y,
;; top_start_x, top_end_x, bottom_start_x, bottom_end_x
;;
;; so for a top panel, we set top, top_start_x, and top_end_x.
(let ((strut-height (+ height (slot-value window 'margin-top)
(slot-value window 'margin-bottom))))
(xu:window-property-set xcontext "_NET_WM_STRUT_PARTIAL"
(xu:make-numbers-property
(if (eq? position 'bottom)
(list 0 0 0 strut-height 0 0 0 0 0 0 0 0)
(list 0 0 strut-height 0 0 0 0 0 0 0 0 0)))))
(xu:set-wm-protocols xcontext '(WM_DELETE_WINDOW))
(when (window-lower)
(xlowerwindow display xwindow))
(xselectinput display xwindow
(bitwise-ior EXPOSUREMASK
BUTTONPRESSMASK
STRUCTURENOTIFYMASK))
(xmapwindow display xwindow)
(xnextevent display (make-xevent))
(window-expose window)
(xu:xcontext-data-set! xcontext window)
(xu:add-event-handler! xcontext
CLIENTMESSAGE
STRUCTURENOTIFYMASK
window-handle-event/clientmessage
#f)
(xu:add-event-handler! xcontext
EXPOSE
EXPOSUREMASK
window-handle-event/expose
#f)
(xu:add-event-handler! xcontext
BUTTONPRESS
BUTTONPRESSMASK
window-handle-event/buttonpress
#f)
(push! xcontext xcontexts)))))
(define (window-get-create-font window font)
(let ((fonts (slot-value window 'fonts)))
(or (alist-ref font fonts)
(xu:with-xcontext (slot-value window 'xcontext)
(display screen)
(let ((fontref (xft-font-open/name display screen font)))
(set! (slot-value window 'fonts)
(cons (cons font fontref)
fonts))
fontref)))))
(define window-expose
(case-lambda
((window xrectangle)
;; exposing a given rectangle means drawing all widgets which
;; intersect that rectangle, passing the rectangle in to them so they
;; can use it as a mask (via a region).
(xu:with-xcontext (slot-value window 'xcontext) (xcontext display)
(let ((xwindow (xu:xcontext-window xcontext))
(widgets (slot-value window 'widgets))
(r (xcreateregion)))
(xunionrectwithregion xrectangle (xcreateregion) r)
(llog expose "window ~A, ~A"
(slot-value window 'id)
(xrectangle->string xrectangle))
(for-each
(lambda (widget)
;; does this widget intersect xrectangle?
(let* ((wrect (slot-value widget 'xrectangle))
(x (xrectangle-x wrect))
(y 0)
(width (xrectangle-width wrect))
(height (slot-value window 'height)))
(when (member (xrectinregion r x y width height)
(L RECTANGLEPART RECTANGLEIN))
;;intersect r with wrect and pass result to widget-draw
(let ((wreg (xcreateregion))
(out (xcreateregion)))
(xunionrectwithregion wrect out wreg)
(xintersectregion r wreg out)
(widget-draw widget out)))))
widgets)
;; if the entire window is not filled with widgets, we may need to
;; clear the area to the right of the last widget.
(unless (null? widgets)
(let* ((lastwidget (last widgets))
(wrect (slot-value lastwidget 'xrectangle))
(p (+ (xrectangle-x wrect)
(xrectangle-width wrect)))
(m (+ (xrectangle-x xrectangle)
(xrectangle-width xrectangle))))
(when (> m p)
(xcleararea display xwindow
p 0 (- m p) (slot-value window 'height)
0))))
(xflush display))))
((window)
(window-expose window
(make-xrectangle
0 0 (slot-value window 'width)
(slot-value window 'height))))))
;; window-update-widget-dimensions! sets x coordinates and widths of all
;; widgets in window. returns #f if nothing changed, otherwise an
;; xrectangle of the changed area.
;;
(define (window-update-widget-dimensions! window)
(let* ((widgets (slot-value window 'widgets))
(widsum 0)
(flexsum 0)
(wids (map ;; sum widths & flexes, and accumulate widths
(lambda (widget)
(and-let* ((flex (slot-value widget 'flex)))
(inc! flexsum flex))
(and-let* ((wid (widget-preferred-width widget)))
(inc! widsum wid)
wid))
widgets))
(remainder (- (slot-value window 'width) widsum))
(x 0)
(rmin #f) ;; redraw range
(rmax #f))
(define (flex-allocate flex)
(if (zero? flexsum)
#f
(let ((flexwid (inexact->exact (round (* (/ flex flexsum) remainder)))))
(set! remainder (- remainder flexwid))
(set! flexsum (- flexsum flex))
flexwid)))
(for-each
(lambda (widget wid)
(let* ((rect (slot-value widget 'xrectangle))
(wid (or wid (flex-allocate (slot-value widget 'flex))))
(oldx (xrectangle-x rect))
(oldwid (xrectangle-width rect)))
(unless (and (= oldx x)
(= oldwid wid))
(set! rmin (min (or rmin x) oldx x))
(let ((rt (+ x wid))
(oldrt (+ oldx oldwid)))
(set! rmax (max (or rmax rt) oldrt rt))))
(set-xrectangle-x! rect x)
(set-xrectangle-width! rect wid)
(inc! x wid)))
widgets
wids)
(if rmin
(make-xrectangle rmin 0 (- rmax rmin) (slot-value window 'height))
#f)))
(define (window-widget-at-position window x)
(find
(lambda (widget)
(let ((wrect (slot-value widget 'xrectangle)))
(and (>= x (xrectangle-x wrect))
(< x (+ (xrectangle-x wrect)
(xrectangle-width wrect))))))
(slot-value window 'widgets)))
(define (window-handle-event/clientmessage xcontext event)
;;XXX: there may be important information in
;; xclientmessageevent-message_type
(quit-mowedline))
(define (window-handle-event/expose xcontext event)
(and-let* ((window (xu:xcontext-data xcontext))
(x (xexposeevent-x event))
(y (xexposeevent-y event))
(width (xexposeevent-width event))
(height (xexposeevent-height event)))
(window-expose window (make-xrectangle x y width height))))
(define (window-handle-event/buttonpress xcontext event)
(let ((window (xu:xcontext-data xcontext)))
(parameterize ((current-xcontext (slot-value window 'xcontext)))
(and-let* ((widget (window-widget-at-position
window (xbuttonpressedevent-x event)))
(button (widget-button-at-position
widget (xbuttonpressedevent-x event))))
((button-handler button) widget)))))
;;;
;;; Widgets
;;;
(define-generic (widget-draw widget region))
(define-generic (widget-preferred-height widget))
(define-generic (widget-preferred-width widget))
(define-generic (widget-preferred-baseline widget))
(define-generic (widget-set-window! widget window))
(define-generic (widget-init widget))
(define-generic (widget-update widget params))
(define widget-background-color (make-parameter #f))
(define widget-flex (make-parameter #f))
(define-class ()
((name initform: #f)
(flex initform: (widget-flex))
(window)
(xrectangle initform: (make-xrectangle 0 0 0 0))
(background-color initform: (widget-background-color))
(buttons initform: (list))))
(define-method (initialize-instance (widget ))
(call-next-method)
(and-let* ((name (slot-value widget 'name)))
(when (hash-table-exists? *widgets* name)
(error "duplicate widget name"))
(hash-table-set! *widgets* name widget)))
(define-method (widget-set-window! (widget ) (window ))
(set! (slot-value widget 'window) window))
(define-method (widget-init (widget ))
(let ((window (slot-value widget 'window)))
(set-xrectangle-height! (slot-value widget 'xrectangle)
(slot-value window 'height))))
(define-method (widget-preferred-baseline (widget )) 0)
(define-method (widget-preferred-height (widget )) 1)
(define-method (widget-preferred-width (widget ))
(if (slot-value widget 'flex)
#f
1))
(define-method (widget-draw (widget ) region)
(let ((window (slot-value widget 'window)))
(xu:with-xcontext (slot-value window 'xcontext) (xcontext display)
(let* ((xwindow (xu:xcontext-window xcontext))
(wrect (slot-value widget 'xrectangle))
(x (xrectangle-x wrect))
(visual (xdefaultvisual display (xdefaultscreen display)))
(colormap (xdefaultcolormap display (xdefaultscreen display)))
(draw (xftdraw-create display xwindow visual colormap)))
(define (make-color c)
(apply make-xftcolor display visual colormap
(ensure-list c)))
(let ((background-color (slot-value widget 'background-color)))
(xftdraw-set-clip! draw region)
(if background-color
(xft-draw-rect draw (make-color background-color) x 0
(xrectangle-width wrect)
(xrectangle-height wrect))
(xcleararea display xwindow x 0
(xrectangle-width wrect)
(xrectangle-height wrect)
0)))))))
(define (widget-button-at-position widget x)
(find
(lambda (button)
(let ((rect (button-xrectangle button)))
(and (>= x (xrectangle-x rect))
(< x (+ (xrectangle-x rect)
(xrectangle-width rect))))))
(slot-value widget 'buttons)))
;; Spacer
;;
(define-class ()
((width initform: #f)))
(define (widget:spacer . args)
(apply make args))
(define-method (widget-preferred-width (widget ))
(if (slot-value widget 'flex)
#f
(or (slot-value widget 'width) 1)))
;; Text Widget
;;
(define text-widget-font (make-parameter "mono-10:bold"))
(define text-widget-color (make-parameter (list 1 1 1 1)))
(define text-widget-format (make-parameter identity))
(define-class ()
((text initform: "")
(font initform: (text-widget-font))
(color initform: (text-widget-color))
(format initform: (text-widget-format))))
(define (widget:text . args)
(apply make args))
(define-method (initialize-instance (widget ))
(call-next-method)
;; apply formatting to default text
(widget-update widget (list (slot-value widget 'text))))
(define-method (widget-draw (widget ) region)
(let ((window (slot-value widget 'window)))
(xu:with-xcontext (slot-value window 'xcontext) (xcontext display)
(let* ((xwindow (xu:xcontext-window xcontext))
(wrect (slot-value widget 'xrectangle))
(font (window-get-create-font window (slot-value widget 'font)))
(x (xrectangle-x wrect))
(baseline (slot-value window 'baseline))
(visual (xdefaultvisual display (xdefaultscreen display)))
(colormap (xdefaultcolormap display (xdefaultscreen display)))
(draw (xftdraw-create display xwindow visual colormap)))
(define (make-color c)
(apply make-xftcolor display visual colormap
(ensure-list c)))
(set! (slot-value widget 'buttons) (list))
(let ((color (make-color (slot-value widget 'color)))
(background-color (slot-value widget 'background-color)))
(xftdraw-set-clip! draw region)
(if background-color
(xft-draw-rect draw (make-color background-color) x 0
(xrectangle-width wrect)
(xrectangle-height wrect))
(xcleararea display xwindow x 0
(xrectangle-width wrect)
(xrectangle-height wrect)
0))
(let walk ((term (slot-value widget 'text))
(fonts (list font))
(colors (list color)))
(cond
((string? term)
(xft-draw-string draw (first fonts) (first colors) x baseline term)
(inc! x (xglyphinfo-xoff (xft-text-extents display (first fonts) term))))
((pair? term)
(cond
((eq? 'button (first term))
(let ((handler (second term))
(buttonx1 x))
(walk (cddr term) fonts colors)
(push! (make-button (make-xrectangle buttonx1 0
(- x buttonx1)
(xrectangle-height wrect))
handler)
(slot-value widget 'buttons))))
((eq? 'color (first term))
(walk (cddr term) fonts (cons (make-color (second term)) colors)))
((eq? 'font (first term))
(walk (cddr term) (cons (window-get-create-font window (second term)) fonts) colors))
(else
(walk (first term) fonts colors)
(walk (rest term) fonts colors)))))))))))
(define-method (widget-preferred-baseline (widget ))
(xftfont-ascent (window-get-create-font
(slot-value widget 'window)
(slot-value widget 'font))))
(define-method (widget-preferred-height (widget ))
;; i find even common fonts extend a pixel lower than their
;; declared descent. tsk tsk.
(let ((font (window-get-create-font
(slot-value widget 'window)
(slot-value widget 'font))))
(+ (xftfont-ascent font) (xftfont-descent font) 2)))
(define-method (widget-preferred-width (widget ))
(let ((window (slot-value widget 'window)))
(xu:with-xcontext (slot-value window 'xcontext) (display)
(define (x-extent str font)
(xglyphinfo-xoff
(xft-text-extents display
(window-get-create-font window font)
str)))
(if (slot-value widget 'flex)
#f
(let walk ((term (slot-value widget 'text))
(font (slot-value widget 'font)))
(cond
((null? term) 0)
((string? term) (x-extent term font))
((pair? term)
(cond
((eq? 'font (first term))
(walk (cddr term) (second term)))
((memq (first term) '(color button))
(walk (cddr term) font))
(else
(+ (walk (first term) font)
(walk (rest term) font)))))
(else 0)))))))
(define-method (widget-update (widget ) params)
(set! (slot-value widget 'text)
((slot-value widget 'format) (first params))))
;; Clock
;;
(define (clock-thread widget)
(lambda ()
(let loop ()
(let* ((time (seconds->local-time (current-seconds)))
(s (vector-ref time 0)))
(mailbox-send!
*internal-events*
(lambda ()
(update widget
(time->string time (slot-value widget 'time-format)))))
(thread-sleep! (- 60 s)))
(loop))))
(define-class ()
((time-format initform: "%a %b %e %H:%M %Z %Y")))
(define (widget:clock . args)
(apply make args))
(define-method (widget-init (widget ))
(call-next-method)
(thread-start! (make-thread (clock-thread widget))))
;; Flags
;;
(define-class ()
((flags initform: '())
(curflags initform: '())))
(define (widget:flags . args)
(apply make args))
(define-method (widget-update (widget ) params)
(let* ((changes (first params))
(op (cond ((string-prefix? "+" changes) 'add)
((string-prefix? "-" changes) 'remove)
(else 'replace)))
(tokenize-start (if (eq? 'replace op) 0 1))
(tokens (string-tokenize changes char-set:graphic tokenize-start)))
(case op
((add)
(set! (slot-value widget 'curflags)
(lset-union equal? (slot-value widget 'curflags) tokens)))
((remove)
(set! (slot-value widget 'curflags)
(lset-difference equal? (slot-value widget 'curflags) tokens)))
((replace)
(set! (slot-value widget 'curflags) tokens)))
(let ((curflags (slot-value widget 'curflags)))
(set!
(slot-value widget 'text)
((slot-value widget 'format)
(fold (lambda (flagdef result)
(let ((flag (first flagdef))
(r (rest flagdef)))
(if (member flag curflags)
(cons r result)
result)))
'()
(reverse (slot-value widget 'flags))))))))
;; Map
;;
(define (map-format-pair k v)
(string-append (->string k) "=" (->string v)))
(define-class