Create a gist now

Instantly share code, notes, and snippets.

@kikairoya /wandbox.l
Last active Dec 28, 2015

What would you like to do?
post to wandbox from xyzzy
(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")

well done lad I haven't learnt this language but I shall enjoy it so thoroughly I will crap my pants.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment