;;;; wmiirc.scm
;
;; A library for writing wmii configuration scripts
;;
;; This wmiirc is for wmii 3.6
;;
; Copyright (c) 2008, Peter Bex
; 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.
; 3. Neither the name of the author nor the names of its
;    contributors may be used to endorse or promote products derived
;    from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "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 THE
; COPYRIGHT HOLDERS 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.
;
; Please report bugs, suggestions and ideas to the Chicken Trac
; ticket tracking system (assign tickets to user 'sjamaan'):
; http://trac.callcc.org

(module wmiirc
 (connect write read
  read-lines directory
  colrules colrules-set!
  tagrules tagrules-set!
  key-code->string string->key-code
  grabbed-keys grabbed-keys-set!
  event-handlers event-handlers-set!
  client=? event-loop
  color->string string->color
  global-settings global-settings-set!
  tag tag-settings tag-settings-set!
  change-state kill navigate-to send-to
  goto-tag client-tags client-tags-set!
  tags clients write-tab destroy-tab
  tabs quit exec)

(import (except scheme write read) chicken)

(require-library extras srfi-1 srfi-13 data-structures regex 9p-client)

(import	(except extras read-lines)
	(prefix (only extras read-lines) extras:)
	srfi-1 srfi-13 data-structures
        regex (prefix 9p-client 9p:))

(define *connection* #f)

(define (camelcased->dasherized str)
  (list->string
   (reverse
    (string-fold
     (lambda (c l)
       (if (char-upper-case? c)
	   (if (not (null? l))
	       (cons (char-downcase c) (cons #\- l))
	       (cons (char-downcase c) l))
	   (cons c l))) '() str))))

(define (dasherized->camelcased str . rest)
  (let-optionals rest ((initial-caps #f))
    (let ((pieces (string-split str "-")))
      (if initial-caps
	  (apply string-append (map string-titlecase pieces))
	  (apply string-append (car pieces) (map string-titlecase (cdr pieces)))))))

(define (connect . rest)
  (let-optionals rest ((inport #f)
		       (outport #f))
   (set! *connection*
	 (if (and inport outport)
	     (9p:client-connect inport outport)
	     (call-with-values
		 (lambda ()
		   (require-extension unix-sockets)
		   (unix-connect (sprintf "/tmp/ns.~A.~A/wmii"
					  (getenv "USER") (getenv "DISPLAY"))))
	       9p:client-connect)))
   *connection*))

(define (read file)
  (9p:with-input-from-file *connection* file read-string))

(define (read-lines file)
  (9p:with-input-from-file *connection* file extras:read-lines))

(define (write file data)
  (9p:with-output-to-file *connection* file (lambda () (display data))))

(define (directory path)
  (9p:directory *connection* path))

(define (alist->rules alist)
  (apply string-append
   (map
    (lambda (rule)
      (sprintf "/~A/ -> ~A\n"
	       (car rule)
	       (if (pair? (cdr rule))
		   (string-join (map ->string (cdr rule)) "+")
		   (->string (cdr rule)))))
    alist)))

(define (rules->alist rules)
  (reverse
    (map
     (lambda (rule)
       (let ((result (string-match "^/([^/]+)/\\s*->\\s*(.*)$" rule)))
         (cons (second result) (string-split (third result) "+"))))
     rules)))

(define (colrules)
  (map (lambda (entry)
         (cons (car entry)
               (map string->number (cdr entry))))
       (rules->alist (read-lines "/colrules"))))

(define (colrules-set! rules)
  (write "/colrules" (alist->rules rules)))

(define (tagrules)
  (rules->alist (read-lines "/tagrules")))

(define (tagrules-set! rules)
  (write "/tagrules" (alist->rules rules)))

(define (key-code->string key-code)
  (string-join key-code "-"))

(define (string->key-code str)
  (string-split str "-"))

(define (grabbed-keys)
  (map string->key-code (read-lines "/keys")))

(define (grabbed-keys-set! keys)
  (9p:with-output-to-file *connection* "/keys"
    (lambda ()
      (for-each
       (lambda (key)
	 (printf "~a\n" (key-code->string key)))
       keys))))

(define *event-handlers* (list))

(define (event-handlers)
  *event-handlers*)

;; Option for not being smart about grabbed keys?
(define (event-handlers-set! handlers . rest)
  (let-optionals rest ((grab-keys #t))  
    (if grab-keys
	(let loop ((handlers handlers)
		   (keys '()))
	  (if (null? handlers)
	      (grabbed-keys-set! keys)
	      (if (and (pair? (caar handlers)) (eq? (caaar handlers) 'key))
                  (let ((key-code (cdaar handlers)))
                    (loop (cdr handlers) (cons key-code keys)))
                  (loop (cdr handlers) keys))))))
  (set! *event-handlers* handlers))

(define (parse-event line)
  (let* ((parts (string-split line))
	 (type (string->symbol (camelcased->dasherized (car parts)))))
    (case type
      ((key)
       (cons type (string->key-code (second parts))))
      ((urgent-tag not-urgent-tag)
       (list type (third parts) (string=? (second parts) "Client")))
      ((urgent not-urgent)
       (list type (second parts) (string=? (third parts) "Client")))
      ((client-mouse-down client-click)
       (list type (second parts) (string->number (third parts))))
      (else
       (cons type (cdr parts))))))

(define client=? string=?)

(define (handle-event event)
  (let ((handler (alist-ref event
			    *event-handlers*
			    (lambda (template event)
			      (if (pair? template)
				  (equal? template event)
				  (eq? template (car event)))))))
    (if handler
	(apply handler event))))

(define (event-loop . rest)
  (let-optionals rest ((kill-others #t))
    (if kill-others (write "/event" "Start wmiirc")) ;; Kill off any running wmiirc
    (9p:with-input-from-file *connection* "/event"
      (lambda ()
	(let loop ()
	  (let ((event (parse-event (read-line))))
	    (unless (equal? event '(start "wmiirc")) ;; Otherwise, return
		    (condition-case (handle-event event)
				    (exn (9p-server-error)
					 (fprintf (current-error-port)
						  "Server error: ~A\n"
						  ((condition-property-accessor 'exn 'message) exn))
					 (loop)))
		    (loop))))))))

(define (color->string color)
  (string-append "#" (string-pad (number->string color 16) 6 #\0)))

(define (string->color str)
  (string->number (string-drop str 1) 16))

(define (settings->alist settings)
 (map (lambda (line)
	(let* ((contents (string-split line))
	       (setting (cons (string->symbol (car contents)) (cdr contents))))
	  (case (car setting)
	    ((focuscolors normcolors)
	     (cons (car setting) (map string->color (cdr setting))))
	    (else
	     (if (null? (cddr setting))
		 (cons (car setting) (cadr setting))
		 setting)))))
      (if (pair? settings)
	  settings
	  (string-split settings "\n"))))

(define (alist->settings alist)
  (string-join
   (map (lambda (setting)
	  (case (car setting)
	    ((focuscolors normcolors) (sprintf "~A ~A\n" (car setting) (string-join (map color->string (cdr setting)))))
	    (else (if (pair? (cdr setting))
		      (sprintf "~A ~A\n" (car setting) (string-join (cdr setting)))
		      (sprintf "~A ~A\n" (car setting) (cdr setting))))))
	alist)))

(define (global-settings)
  (settings->alist (read "/ctl")))

(define (global-settings-set! alist)
  (write "/ctl" (alist->settings alist)))

(define (tag . rest)
  (let-optionals rest ((tag "sel"))
    (car (read-lines (sprintf "/tag/~A/ctl" tag)))))

(define (tag-settings . rest)
  (let-optionals rest ((tag "sel"))
    (settings->alist
     (cdr (read-lines (sprintf "/tag/~A/ctl" tag))))))

(define (tag-settings-set! alist . rest)
  (let-optionals rest ((tag "sel"))
    (write (sprintf "/tag/~A/ctl" tag) (alist->settings alist))))

(define (state-transition->string b)
  (case b
    ((#t) "on")
    ((#f) "off")
    ((toggle) "toggle")
    (else (error (sprintf "Unknown state transition type ~S" b)))))

(define (string->state-transition s)
  (cond
   ((string=? s "on") #t)
   ((string=? s "off") #f)
   ((string=? s "toggle") 'toggle)
   (else (error (sprintf "Unknown state transition type ~S" s)))))

;; Unfortunately, there's no client-settings because this information is
;; not exported by wmii.
(define (change-state state value . rest)
  (let-optionals rest ((client "sel"))
    (write (sprintf "/client/~A/ctl" client)
		(sprintf "~a ~a" state (state-transition->string value)))))

(define (kill . rest)
  (let-optionals rest ((client "sel"))
    (write (sprintf "/client/~A/ctl" client) "kill")))

(define (navigate-to where . rest)
  (let-optionals rest ((tag "sel"))
   (write (sprintf "/tag/~A/ctl" tag) (sprintf "select ~A" where))))

(define (send-to direction . rest)
  (let-optionals rest ((client "sel")
		       (tag "sel"))
   (write (sprintf "/tag/~A/ctl" tag)
	       (sprintf "send ~A ~A" client direction))))

(define (goto-tag tag)
  (write "/ctl" (sprintf "view ~A" tag)))

(define (client-tags . rest)
  (let-optionals rest ((client "sel"))
   (string-split (read (sprintf "/client/~A/tags" client)) "+")))

(define (client-tags-set! tags . rest)
  (let-optionals rest ((client "sel"))
   (write (sprintf "/client/~A/tags" client) (string-join tags "+"))))

(define (tags)
  (delete "sel" (9p:directory *connection* "/tag")))

(define (clients . tags)
  (let ((clients (delete "sel" (9p:directory *connection* "/client"))))
    (if (null? tags)
        clients
        (filter! (lambda (c)
                   (any (lambda (x) (member x tags string=?)) (client-tags c)))
                 clients))))

(define (write-tab bar tab contents . rest)
  (let-optionals rest ((colors #f))
   (write (sprintf "~A/~A" bar tab)
	       (if colors
		   (sprintf "~A ~A" (string-join (map color->string colors)) contents)
		   contents))))

(define (destroy-tab bar tab)
  (9p:delete-file *connection* (sprintf "~A/~A" bar tab)))

(define (tabs bar)
  (directory bar))

(define (quit)
  (write "/ctl" "quit"))

(define (exec cmdline)
  (write "/ctl" (sprintf "exec ~A" cmdline)))
)