;;; xprop

;;; Copyright (C) 2007 Thien-Thi Nguyen

(use-modules
 ((ice-9 pretty-print) #:select (pretty-print))
 ((srfi srfi-13) #:select (string-join))
 ((ttn-do zzz x-protocol) #:prefix xsb))

(define CONN (or (xsb-connect) (exit #f)))
(define ROOT-WINDOW-ID (xsb-x '(roots 0 root) (vector-ref CONN 1)))

(define q (xsb-synchronous-request-proc CONN 'plist-input))

(define ROOTW-PROPERTY-ATOMS
  (xsb-x 'atoms (q 'ListProperties `(window ,ROOT-WINDOW-ID))))

(define ROOTW-PROPERTY-NAMES
  (map (lambda (atom)
         (xsb-x 'name (q 'GetAtomName `(atom ,atom))))
       ROOTW-PROPERTY-ATOMS))

(define -TYPES '((4 . ATOM)
                 (6 . CARDINAL)
                 (19 . INTEGER)
                 (31 . STRING)
                 (33 . WINDOW)))

(define (fs s . args)
  (apply simple-format #f s args))

(define (hexs n)
  (fs "#x~A" (number->string n 16)))

(define (atom-name atom)
  (xsb-x 'name (q 'GetAtomName `(atom ,atom))))

(for-each (lambda (atom name)

            (define (get . rest)
              (q 'GetProperty `(window
                                ,ROOT-WINDOW-ID
                                property
                                ,atom
                                ,@rest)))

            (let* ((a (get))
                   (type (xsb-x 'type a))
                   (known (assq-ref -TYPES type))
                   (pretty (and known (fs " (~A)" known)))
                   (after (xsb-x 'bytes-after a)))

              (define (get-again proc)
                (string-join
                 (map proc (xsb-x 'value (get 'type type
                                              'long-length after)))
                 ", " 'infix))

              (write-line
               (fs "property[~A]: ~A~A" atom name
                   (case (or known type)
                     ((ATOM)
                      (fs "~A = ~A" pretty (get-again atom-name)))
                     ((CARDINAL INTEGER)
                      (fs "~A = ~A" pretty (get-again number->string)))
                     ((STRING)
                      (fs "~A = ~S" pretty (get-again identity)))
                     ((WINDOW)
                      (fs "~A: window id # ~A" pretty (get-again hexs)))
                     (else
                      " ???"))))))
          ROOTW-PROPERTY-ATOMS
          ROOTW-PROPERTY-NAMES)

(exit (xsb-disconnect CONN))

;;; xprop ends here