;;; debug-utils.jl --- debugging functions

;; Copyright (C) 2010 Jeremy Hankins

;; Author: Jeremy Hankins <nowan at nowan dot org>
;; $Date: 2010-11-02 09:04:52 -0500 (Tue, 02 Nov 2010) $
;; $Revision: 1263 $

;;; GPL blurb

;; This file 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 2, or (at your option)
;; any later version.

;; This file 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.

;;; Commentary

;; Miscelaneous functions that may be useful for debugging sawfish.
;;
;; To use:
;;
;; (require 'debug-utils)
;;
;; To use the window snooper you'll want something like this in your
;; .sawfishrc:
;;
;; (bind-keys global-keymap
;;            "C-S-s" 'window-snooper)
;;
;; Use `warn' and `display-warning' to send debugging messages to
;; standard-error or to the display, respectively.
;;
;; To log window creation and destruction, as well as to notify you of
;; any lost and/or found windows put this in your .sawfishrc:
;;
;; (add-hook 'after-initialization-hook window-logger-init)
;;

;;; Code:

(define-structure debug-utils

    (export set-debug-buffer-length
            clear-debug-display
            warn
            warnf
            display-warning
            get-window-properties
            window-logger-init
            window-logger-disable
            window-snooper)

    (open rep
          rep.regexp
          rep.system
          rep.io.timers
          rep.data.ring
          sawfish.wm.misc
          sawfish.wm.fonts
          sawfish.wm.windows
          sawfish.wm.commands)

  (defvar debug-message-timeout 15
    "How long debug displays are shown on the screen.  If nil messages
never time out.")

  (defvar debug-clear-buffer-on-timeout t
    "Whether the buffer holding debug messages should be cleared when
the display times out according to `debug-message-timeout'.")

  (defvar debug-message-font (get-font "fixed")
    "The font to use to display debug messages on-screen.  Warning
messages are formatted to use a fixed-width font, but `fixed' is
probably not the prettiest")

  (defvar window-logger-poll-delay 60
    "Number of seconds between polls for lost or found windows.")

  ;; Length (in lines) of the buffer holding debug messages.  This is
  ;; a default value; the proper way to change it is to call
  ;; `set-debug-buffer-length'.
  (define debug-buffer-length 50)

  (define message-buffer (make-ring debug-buffer-length))

  (define message-timeout-timer nil)

  (define (set-debug-buffer-length l)
    "Set the length of the debug buffer to `l'."
    (setq debug-buffer-length l)
    (new-message-buffer t))

  (define (new-message-buffer #!optional preserve)
    "Re-create the message buffer.  If `preserve' is t, copy the
contents of the old buffer into the new buffer."
    (let ((new-buffer (make-ring debug-buffer-length)))
      (when preserve
        (let loop ((i (1- (ring-size message-buffer))))
             (unless (< i 0)
               (ring-append new-buffer (ring-ref message-buffer i))
               (loop (1- i)))))
      (setq message-buffer new-buffer)))

  (define (warning #!rest values)
    "Format a warning message made up of all values passed.  The
message begins with a timestamp.  If any of the items in `values' are
not strings a textual representation is generated using
`prin1-to-string'.  Whitespace is added where it seems appropriate.
The output looks best with a fixed-width font."
    (format nil "%s: %s\n"
            (current-time-string nil "%H:%M:%S")
            (mapconcat (lambda (obj)
                         ;; Pretty-print it by adding a bit of
                         ;; whitespace:
                         (if (stringp obj)
                             (string-replace "\n" "\n          "
                                             (if (string-match "\\s$" obj)
                                                 obj
                                               (concat obj " ")))
                           (concat (prin1-to-string obj) " ")))
                       values "")))

  (define (display-debug-message message #!optional timeout)
    "Display a message on the screen with a timeout.  If no timeout is
provided `debug-message-timout' is used."
    ;; Split `message' into lines and add each line to the message
    ;; buffer.
    (mapc (lambda (i)
            (ring-append message-buffer i))
          (string-split "\n" (string-replace "\n$" "" message)))
    (display-message (mapconcat identity
                                (reverse (ring->list message-buffer)) "\n")
                     (list (cons 'font debug-message-font)))
    (let ((seconds (or timeout debug-message-timeout)))
      (when seconds
        (when message-timeout-timer
          (delete-timer message-timeout-timer))
        (setq message-timeout-timer
              (make-timer
               (lambda ()
                 (clear-debug-display debug-clear-buffer-on-timeout))
               seconds)))))

  (define (clear-debug-display #!optional erase)
    "Remove any messages displayed.  If `erase' is non-nil erase the
message buffer as well."
    (when message-timeout-timer
      (delete-timer message-timeout-timer)
      (setq message-timeout-timer nil))
    (when erase
      (new-message-buffer))
    (display-message nil))

  (define (warn #!rest values)
    "Send a warning message to `standard-error'.  See `warning' for
info on how the values are treated."
    (princ (apply warning values) standard-error))

  (define (warnf #!rest args)
    "Send a formatted warning string to `standard-error'.  See
`format' for details on how the string is composed.  A newline is
appended to the output."
    (apply format standard-error args)
    (princ "\n" standard-error))

  ;; TODO: This should really break very long lines, since
  ;; display-message just lets them run off the edge of the screen.
  (define (display-warning #!rest values)
    "Display a warning message on the screen.  See `warning' for info
on how the values are treated."
    (display-debug-message (apply warning values)))

;;;
;;; Logging window creation/destruction.
;;;

  (define window-logger-list nil)
  (define window-logger-timer nil)
  (define window-logger-active nil)

  (define (window-logger-poll)
    (let ((windows (managed-windows)))
      (let loop ((rest window-logger-list))
           (when rest
             (cond
              ((not (member (caar rest) windows))
               (warnf "Lost(!) window named \"%s\"" (cdar rest))
               (setq window-logger-list
                     (delete-if (lambda (e)
                                  (equal (cdr e) (cdar rest)))
                                window-logger-list)))
              (t
               (setq windows (delete (caar rest) windows))
               (rplacd (car rest) (window-name (caar rest)))))
             (loop (cdr rest))))
      (let loop ((rest windows))
           (when rest
             (let ((name (window-name (car rest))))
               (warnf "Found new window named \"%s\"" name)
               (setq window-logger-list
                     (cons (cons (car rest) name) window-logger-list)))
             (loop (cdr rest)))))
    (set-timer window-logger-timer window-logger-poll-delay))


  (define (window-logger-destroy-window w)
    (when window-logger-active
      (warnf "Destroyed window named \"%s\"" (window-name w))
      (setq window-logger-list
            (delete-if (lambda (e)
                         (equal (car e) w))
                       window-logger-list))))

  (define (window-logger-add-window w)
    (when window-logger-active
      (warnf "Created new window named \"%s\"" (window-name w))
      (setq window-logger-list
            (cons (cons w (window-name w)) window-logger-list))))

  (define (window-logger-init)
    (when window-logger-timer
      (delete-timer window-logger-timer))
    (setq window-logger-active t
          window-logger-timer (make-timer window-logger-poll))
    (window-logger-poll))

  (define (window-logger-disable)
    (delete-timer window-logger-timer)
    (setq window-logger-active nil
          window-logger-list nil))

  (add-hook 'destroy-notify-hook window-logger-destroy-window)
  (add-hook 'after-add-window-hook window-logger-add-window)

;;;
;;; Window Snooping
;;;
;;; This is (slightly modified) code by Christopher Bratusek.
;;;

  (define (get-window-properties w)
    "Generate a list of property/value pairs for every window property."
    (let (props)
      (map-window-properties (lambda (p v)
                               (setq props (cons (cons p v) props)))
                             w)
      props))

  (define (window-snooper)
    "Display information about the focused window."
    (let* ((w (input-focus))
           (name (window-name w))
           (net-wm-name (get-x-text-property w '_NET_WM_NAME))
           (wm-class (get-x-text-property w 'WM_CLASS))
           (net-wm-icon-name (get-x-text-property w '_NET_WM_ICON_NAME))
           (wm-window-role (get-x-text-property w 'WM_WINDOW_ROLE))
           (wm-locale-name (get-x-text-property w 'WM_LOCALE_NAME))
           (pos (window-position w))
           (dims (window-dimensions w))
           (frame-dims (window-frame-dimensions w))
           (window-x (car pos))
           (window-y (cdr pos))
           (window-width (car dims))
           (window-height (cdr dims))
           (frame-width (- (car frame-dims) window-width))
           (frame-height (- (cdr frame-dims) window-height)))
    
      (display-debug-message
       (format nil 
               "
About the currently focused window:
===================================

Window name        %s
_NET_WM_NAME:      %s
WM_CLASS:          %s
_NET_WM_ICON_NAME: %s
WM_WINDOW_ROLE:    %s
WM_LOCALE_NAME:    %s
Window X:      %8d pixels
Window Y:      %8d pixels
Window Width:  %8d pixels
Window Height: %8d pixels
Frame Width:   %8d pixels
Frame Height:  %8d pixels

===================================\n"
               name
               (if net-wm-name
                   (aref net-wm-name 0)
                 "")
               (concat (aref wm-class 1)
                       "/"
                       (aref wm-class 0))
               (if net-wm-icon-name
                   (aref net-wm-icon-name 0)
                 "")
               (or wm-window-role "")
               (if wm-locale-name
                   (aref wm-locale-name 0)
                 "")
               window-x
               window-y
               window-width
               window-height
               frame-width
               frame-height))))
  
  (define-command 'window-snooper window-snooper)

  )

;;; debug-utils.jl ends here


;;; Local Variables:
;;; mode:sawfish
;;; End: