#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do xprop)' -s $0 "$@" # -*- scheme -*-
!#
;;; xprop

;; Copyright (C) 2007, 2009, 2010 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: xprop [options]
;;
;; Display properties from the X server root window, one per line.
;; Options are:
;;
;;      --id 0xWID       -- display window properties from WID, a
;;                          hex number, instead of the root window
;;
;; These types of property values are recognized:
;; ATOM, CARDINAL, INTEGER, STRING, UTF8_STRING, WINDOW,
;; WM_STATE, WM_HINTS, WM_SIZE_HINTS.
;;
;; Display values of unrecognized types as raw (uninterpreted) data,
;; i.e., zero or more hex integers.  If the data has STRING format,
;; then each string is represented as a list of hex integers.
;;
;; Usage: xprop [options] --jam PROPERTY TYPE VALUE
;;
;; In this case, don't display properties.  Instead, set PROPERTY
;; (with TYPE) to VALUE on the server, then exit.  PROPERTY and TYPE
;; are symbols or numbers, and VALUE is a Scheme expression, such as a
;; string or a uniform vector.  Here are some command-line examples:
;;
;;  $ ... --jam WM_CLIENT_MACHINE STRING '"foo-bar-baz"'
;;  $ ... --jam WM_CLIENT_LEADER WINDOW '#u(#x400013)'
;;
;; Note that double quotes are required for a Scheme string; the
;; single quotes are for the shell.
;;
;; Usage: xprop [options] --zonk PROPERTY...
;;
;; In this case, don't display properties.  Instead, delete each
;; specified PROPERTY (a symbol or integer) on the server, then exit.

;;; Code:

(define-module (ttn-do xprop)
  #:export ()
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ttn-do zzz personally) #:select (FE fs fso))
  #:use-module ((ttn-do zzz x-protocol) #:select ((-internal-data . zx-int)
                                                  (-x . zx-x)))
  #:use-module ((ttn-do zzz x-umbrages) #:select (connection
                                                  n-from-enum
                                                  string-split-on-null
                                                  atom-manager))
  #:use-module ((ice-9 pretty-print) #:select (pretty-print))
  #:use-module ((srfi srfi-13) #:select (string-join)))

(define-macro (2p produce consume)      ; "two phase", unhygenic
  `(let (,produce)
     (io #:flush!)
     ,consume))

(define (window-properties io wid)
  (let ((properties (2p (cookie (io 'ListProperties #:window wid))
                        (zx-x 'atoms (io cookie)))))

    (define (get property . rest)
      (apply io 'GetProperty
             #:window wid
             #:property property
             rest))

    (define (get-sizes)
      (2p (cookies (map get properties))
          (map (lambda (property alist)
                 (cons (zx-x 'type alist)
                       (zx-x 'bytes-after alist)))
               properties
               (map io cookies))))

    (define (get-details more)
      (2p (cookies (map (lambda (property more)
                          (get property
                               #:type (car more)
                               #:long-length (cdr more)))
                        properties
                        more))
          (map (lambda (property type alist)
                 (list property type (zx-x 'value alist)))
               properties
               (map car more)
               (map io cookies))))

    (get-details (get-sizes))))

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

(define (state<- n)
  (case n
    ((0) 'Withdrawn)
    ((1) 'Normal)
    ((3) 'Iconic)
    (else 'Unknown)))

(define gravity<-
  (let ((alist (delay (let ((forw (hash-ref (zx-int 'ENUMS) 'Gravity)))
                        (map cons (map cdr forw) (map car forw))))))
    (lambda (n)
      (assq-ref (force alist) n))))

(define M "\n\t\t")                     ; more (continuation line leader)

(define-macro (d formals . parts)       ; display
  `(apply-to-args
    data (lambda ,formals
           (fs ,(apply string-append ":"
                       (make-list (length parts) "~A"))
               ,@parts))))

(define-macro (f? pos . fs-args)
  `(if (logbit? ,pos flags)
       (fs ,@fs-args)
       ""))

(define (read-string s)
  (call-with-input-string s read))

(define (fso-prop amgr)

  (define (atom-name n)
    (amgr #:symbolic n))

  (define (out! property type data)
    (let ((pname (atom-name property))
          (tname (atom-name type)))

      (define (format-rhs s proc)
        (fs s (string-join (map proc data) ", " 'infix)))

      ;; TODO: Move down.
      (and (memq tname '(STRING UTF8_STRING))
           (set! data (string-split-on-null (car data))))

      (fso "property[~A]: ~A (~A)~A\n"
           property pname tname
           (case tname
             ((ATOM)
              (format-rhs " = ~A" (lambda (x)
                                    (symbol->string (atom-name x)))))
             ((CARDINAL INTEGER)
              (format-rhs " = ~A" number->string))
             ((STRING UTF8_STRING)
              (format-rhs " = ~A" (lambda (orig)
                                    (substring
                                     (pretty-print orig
                                                   #:port #f
                                                   #:escape-strings? #t)
                                     0 -1))))
             ((WINDOW)
              (format-rhs ": window id # ~A" hexs))
             ((WM_STATE)
              (d (s i)
                 (fs "~Awindow state: ~A" M (state<- s))
                 (fs "~Aicon window: ~A" M (hexs i))))
             ((WM_HINTS)
              (d (flags
                  input init-state
                  icon-pixmap icon-wid icon-x icon-y icon-mask
                  group-wid)
                 (fs "~AClient accepts input or input focus: ~A"
                     M (if (logbit? 0 flags) 'True 'False))
                 (f? 1 "~AInitial state is ~A State."
                     M (state<- init-state))
                 (f? 2 "~Abitmap id # to use for icon: ~A"
                     M (hexs icon-pixmap))
                 (f? 3 "~Awindow id # of icon window: ~A"
                     M (hexs icon-wid))
                 (f? 4 "~Aicon position: ~A, ~A"
                     M icon-x icon-y)
                 (f? 5 "~Abitmap id # of mask for icon: ~A"
                     M (hexs icon-mask))
                 (f? 6 "~Awindow id # of group leader: ~A"
                     M (hexs group-wid))
                 (f? 7 "~A(message?)" M)
                 (f? 8 "~A(urgency?)" M)))
             ((WM_SIZE_HINTS)
              (d (flags
                  x y w h
                  min-w min-h max-w max-h w-inc h-inc
                  min-aspect-x min-aspect-y
                  max-aspect-x max-aspect-y
                  . etc)
                 (f? 0 "~Auser specified location: ~A, ~A"
                     M x y)
                 (f? 1 "~Auser specified size: ~A by ~A"
                     M w h)
                 (f? 2 "~Aprogram specified location: ~A, ~A"
                     M x y)
                 (f? 3 "~Aprogram specified size: ~A by ~A"
                     M w h)
                 (f? 4 "~Aprogram specified minimum size: ~A by ~A"
                     M min-w min-h)
                 (f? 5 "~Aprogram specified maximum size: ~A by ~A"
                     M max-w max-h)
                 (f? 6 "~Aprogram specified resize increment: ~A by ~A"
                     M w-inc h-inc)
                 (let ((mm (lambda (x)
                             (fs "~Aprogram specified ~Aimum aspect ratio:"
                                 M x))))
                   (f? 7 "~A: ~A/~A~A: ~A/~A"
                       (mm 'min) min-aspect-x min-aspect-y
                       (mm 'max) max-aspect-x max-aspect-y))
                 (f? 8 "~Aprogram specified base size: ~A by ~A"
                     M (list-ref etc 0) (list-ref etc 1))
                 (f? 9 "~Awindow gravity: ~A"
                     M (gravity<- (list-ref etc 2)))))
             (else
              (format-rhs " = ~A" (lambda (x)
                                    (if (string? x)
                                        (fs "~A" (map (lambda (c)
                                                        (hexs (char->integer c)))
                                                      (string->list x)))
                                        (hexs x)))))))))

  (lambda (x)
    (apply-to-args x out!)))

(define (do-it! qop)
  (let* ((conn (connection))
         (amgr (atom-manager conn))
         (wid (or (qop 'id (lambda (s)
                             (string->number
                              (substring s 2)
                              16)))
                  (zx-x '(roots 0 root)
                        (conn #:setup)))))
    (define (n<- what x)
      (cond ((number? x) x)
            ((amgr #:numeric x))
            (error (fs "unrecognized ~A: ~S" what x))))
    (cond ((qop 'zonk)
           (FE (map read-string (qop '()))
               (lambda (property)
                 ((conn #:q) 'DeleteProperty
                  #:window wid
                  #:property (n<- 'property property)))))
          ((qop 'jam)
           => (lambda (property)
                (define (jam-error what)
                  (error (fs "missing --jam ~A (try ~A --help)"
                             what (car (command-line)))))
                (set! property (read-string property))
                (let* ((n<-prop-mode (n-from-enum 'PropMode))
                       (args (qop '()))
                       (type (if (pair? args)
                                 (read-string (car args))
                                 (jam-error 'type)))
                       (value (if (pair? (cdr args))
                                  (eval (read-string (cadr args)))
                                  (jam-error 'value))))
                  (fso "setting property ~A type ~A to ~A~%"
                       property type value)
                  ((conn #:q) 'ChangeProperty
                   #:mode (n<-prop-mode 'Replace)
                   #:window wid
                   #:property (n<- 'property property)
                   #:type (n<- 'type type)
                   #:data value))))
          (else
           (FE (window-properties (conn #:io) wid)
               (fso-prop amgr))))
    (conn #:bye)))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   ;; 1.0 -- initial release
                   ;; 1.1 -- add option --id, more wm support
                   ;; 1.2 -- add usage mode --jam
                   ;; 1.3 -- add usage mode --zonk
                   (version . "1.3")
                   (help . commentary)))
  (do-it!
   (qop<-args
    args '((zonk)
           (jam (value #t))
           (id (value #t))))))

;;; xprop ends here