;; Copyright 2015 John J Foerch. All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;;    1. Redistributions of source code must retain the above copyright
;;       notice, this list of conditions and the following disclaimer.
;;
;;    2. Redistributions in binary form must reproduce the above copyright
;;       notice, this list of conditions and the following disclaimer in
;;       the documentation and/or other materials provided with the
;;       distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY JOHN J FOERCH ''AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;; DISCLAIMED. IN NO EVENT SHALL JOHN J FOERCH OR CONTRIBUTORS BE LIABLE
;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
;; ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(module xlib-utils
    (window-property-type
     window-property-format
     window-property-data
     window-property-count
     make-atom-property
     make-number-property
     make-numbers-property
     make-text-property
     window-property-set
     window-property-append
     switch-to-desktop)

(import chicken scheme foreign foreigners)

(use (srfi 4)
     lolevel
     xlib)

(foreign-declare "#include <X11/Xlib.h>")

;;;
;;; Window Property Utils
;;;

(define-record window-property
  type format data count)

(define (make-atom-property display atom-name)
  (let ((data (xinternatom display atom-name 0)))
    (let-location ((data unsigned-long data))
      (make-window-property "ATOM" 32
                            (location data)
                            1))))

(define (make-number-property number)
  (let-location ((data unsigned-long number))
    (make-window-property "CARDINAL" 32 (location data) 1)))

(define (make-numbers-property numbers)
  (let* ((vec (list->u32vector numbers))
         (len (u32vector-length vec))
         (lvec ((foreign-lambda* c-pointer ((u32vector s) (int length))
                  "unsigned long * lvec = malloc(sizeof(unsigned long) * length);"
                  "int i;"
                  "for (i = 0; i < length; i++) {"
                  "    lvec[i] = s[i];"
                  "}"
                  "C_return(lvec);")
                vec len)))
    (set-finalizer! lvec free)
    (make-window-property "CARDINAL" 32 lvec len)))

(define (make-text-property textp)
  (let ((tp (make-xtextproperty)))
    (set-xtextproperty-value! tp (make-locative textp))
    (set-xtextproperty-encoding! tp XA_STRING)
    (set-xtextproperty-format! tp 32)
    (set-xtextproperty-nitems! tp 1)
    tp))

(define (window-property-set display win key value)
  (xchangeproperty display win
                   (xinternatom display key 0)
                   (xinternatom display (window-property-type value) 0)
                   (window-property-format value)
                   PROPMODEREPLACE
                   (window-property-data value)
                   (window-property-count value)))

(define (window-property-append display win key value)
  (xchangeproperty display win
                   (xinternatom display key 0)
                   (xinternatom display (window-property-type value) 0)
                   (window-property-format value)
                   PROPMODEAPPEND
                   (window-property-data value)
                   (window-property-count value)))


;;;
;;; Switch To Desktop
;;;

(define (switch-to-desktop/number display desktop)
  (let ((root (xrootwindow display (xdefaultscreen display)))
        (event-mask (bitwise-ior SUBSTRUCTURENOTIFYMASK
                                 SUBSTRUCTUREREDIRECTMASK))
        (event (make-xclientmessageevent)))
    (set-xclientmessageevent-type! event CLIENTMESSAGE)
    (set-xclientmessageevent-serial! event 0)
    (set-xclientmessageevent-send_event! event 1)
    (set-xclientmessageevent-display! event display)
    (set-xclientmessageevent-window! event root)
    (set-xclientmessageevent-message_type!
     event (xinternatom display "_NET_CURRENT_DESKTOP" 0))
    (set-xclientmessageevent-format! event 32)
    (define make-event-data-l
      (foreign-lambda* void (((c-pointer long) data_l)
                             (long l0) (long l1) (long l2)
                             (long l3) (long l4))
        "data_l[0] = l0; data_l[1] = l1;"
        "data_l[2] = l2; data_l[3] = l3;"
        "data_l[4] = l4;"))
    (make-event-data-l (xclientmessageevent-data-l event)
                       desktop (current-seconds) 0 0 0)
    (xsendevent display root 0 event-mask event)))

(define (switch-to-desktop display desktop)
  (cond
   ((number? desktop) (switch-to-desktop/number display desktop))
   ((string? desktop)
    (let ((root (xrootwindow display (xdefaultscreen display)))
          (MAX_PROPERTY_VALUE_LEN 4096)
          (property (xinternatom display "_NET_DESKTOP_NAMES" 0))
          (req_type (xinternatom display "UTF8_STRING" 0)))
      (let-location ((xa_ret_type unsigned-long)
                     (ret_format int)
                     (ret_nitems unsigned-long)
                     (ret_bytes_after unsigned-long)
                     (ret_prop unsigned-c-string*))
        (xgetwindowproperty display root property
                            0 (/ MAX_PROPERTY_VALUE_LEN 4) 0
                            req_type
                            (location xa_ret_type)
                            (location ret_format)
                            (location ret_nitems)
                            (location ret_bytes_after)
                            (location ret_prop))
        (assert (= req_type xa_ret_type))
        (define find-desktop
          (foreign-lambda* int ((unsigned-c-string target)
                                ((c-pointer unsigned-c-string) names)
                                (unsigned-long nitems))
            "int i, d = 0, atstart = 1;"
            "for (i = 0; i < nitems; i++) {"
            "    if (atstart) {"
            "        if (0 == strcmp(target, &names[0][i]))"
            "            C_return(d);"
            "        atstart = 0;"
            "    }"
            "    if (names[0][i] == 0) {"
            "        atstart = 1;"
            "        d++;"
            "    }"
            "}"
            "C_return(-1);"))
        (let ((desktop-number (find-desktop desktop (location ret_prop) ret_nitems)))
          (when (> desktop-number -1)
            (switch-to-desktop/number display desktop-number))))))))

)