post to wandbox from xyzzy

## wandbox.l
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require 'xml-http-request)
  (require 'json))

(defpackage :wandbox
  (:use :lisp :editor))
(in-package "wandbox")

(export '(post-wandbox-region post-wandbox post-wandbox-string show-compiler-list show-compiler-options))

(defvar *wandbox-compiler-alist* nil)

(defun encode-json-string (s)
  (with-output-to-string (r)
    (princ #\" r)
    (map nil #'(lambda (x) (princ (encode-json-char x) r)) s)
    (princ #\" r)))

(defun encode-json-char (c)
  (case c
    (#\TAB "\\t")
    (#\LFD "\\n")
    (#\RET "\\r")
    (#\C-h "\\b")
    (#\C-l "\\f")
    (#\\ "\\\\")
    (#\" "\\\"")
    (t (let ((uc (char-unicode c)))
         (when uc
           (if (<= 32 uc 126)
               (format nil "~A" c)
             (format nil "\\u~4,'0x" uc)))))))

(defun get-compiler-alist ()
  (or
   *wandbox-compiler-alist*
   (setf *wandbox-compiler-alist* (json:json-decode (xhr:xhr-get "http://melpon.org/wandbox/api/list.json" :key #'xhr:xhr-response-text)))))

(defun refresh-compiler-alist-async (callback)
  (xhr:with-xhr-get-async ("http://melpon.org/wandbox/api/list.json")
    (on :success (res)
        (setf *wandbox-compiler-alist* (json:json-decode (xhr:xhr-response-text res))))
    (on :failure (res)
        (setf *wandbox-compiler-alist* nil))
    (on :complete (res)
        (funcall callback))))

(defun get-default-compiler-options (compiler)
  (map
   'list
   #'(lambda (o)
       (let ((x (cdr (assoc "default" o :test #'string=))))
         (if (stringp x)
             x
           (cdr (assoc "name" o :test #'string=)))))
   (delete-if-not
    #'(lambda (o) (cdr (assoc "default" o :test #'string=)))
    (copy-seq
     (cdr (assoc "switches"
                 (car (member-if
                       #'(lambda (o) (string= (cdr (assoc "name" o :test #'string=)) compiler))
                       (get-compiler-alist))) :test #'string=))))))

(defun do-post-wandbox (compiler str)
  (let ((r (xhr:xhr-post
            "http://melpon.org/wandbox/api/compile.json"
            (concat
             "{\"code\":"
             (encode-json-string str)
             ",\"options\":"
             (encode-json-string (reduce #'(lambda (a b) (concat a "," b)) (get-default-compiler-options compiler) :initial-value ""))
             ",\"compiler\":"
             (encode-json-string compiler)
             "}")
            :headers '(:Content-type "application/json"))))
    (if (= (xhr:xhr-status r) 200)
        (let* ((e (json:json-decode (xhr:xhr-response-text r) :strict nil :json-object :hash-table))
               (cm (gethash "compiler_message" e))
               (pm (gethash "program_message" e))
               (st (gethash "status" e))
               (sg (gethash "signal" e)))
          (if st (format t "exit code: ~A~A\n" st (if sg (format nil " [~A]") "")))
          (if cm (format t "[compiler]\n~A\n" cm))
          (if pm (format t "[program]\n~A\n" pm)))
      (princ (xhr:xhr-status-text r)))))

(defun post-wandbox-region (compiler)
  (interactive "sCompiler:" :default0 "gcc-head")
  (let ((p1 (mark))
        (p2 (point)))
    (post-wandbox-string compiler (buffer-substring (min p1 p2) (max p1 p2)))))

(defun post-wandbox (compiler)
  (interactive "sCompiler:" :default0 "gcc-head")
  (post-wandbox-string compiler (buffer-substring (point-min) (point-max))))

(defun post-wandbox-string (compiler str)
  (interactive "sCompiler\nsProgram" :default0 "gcc-head")
  (long-operation
    (let ((buf (selected-buffer)))
      (with-output-to-temp-buffer ("*compilation*")
        (progn
          (other-window)
          (setf buf (selected-buffer))
          (do-post-wandbox compiler str)
          (set-buffer buf))))))

(defun show-compiler-list ()
  (interactive)
  (let ((buf (selected-buffer)))
    (with-output-to-temp-buffer ("*compilation*")
      (progn
        (other-window)
        (setf buf (selected-buffer))
        (dolist (c (map 'list
                        #'(lambda (o) (cdr (assoc "name" o :test #'string=)))
                        (get-compiler-alist)))
          (princ c)
          (princ #\LFD))
        (set-buffer buf)))))

(defun show-compiler-options (compiler)
  (interactive "sCompiler:" :default0 "gcc-head")
  (let ((buf (selected-buffer)))
    (with-output-to-temp-buffer ("*compilation*")
      (progn
        (other-window)
        (setf buf (selected-buffer))
        (princ compiler)
        (princ #\LFD)
        (dolist (c (get-default-compiler-options compiler))
          (princ c)
          (princ #\LFD))
        (set-buffer buf)))))

(refresh-compiler-alist-async #'(lambda () nil))
(provide "wandbox")