util.lisp (4188B)
1 (in-package :cohost.util) 2 3 (defun make-keyword (str) 4 (intern (string-upcase str) 'keyword)) 5 6 (defun sym->str (sym) 7 (json:lisp-to-camel-case (symbol-name sym))) 8 9 (defun strcat (&rest strings) 10 (apply #'concatenate (cons 'string strings))) 11 12 (defmacro -> (init &rest forms) 13 (let ((accum init)) 14 (loop for form in forms 15 do (if (consp form) 16 (setf accum (list (car form) accum (cadr form))) 17 (setf accum (list form accum)))) 18 accum)) 19 20 (defmacro ->> (init &rest forms) 21 (let ((accum init)) 22 (loop for form in forms 23 do (if (consp form) 24 (setf accum (append form (list accum))) 25 (setf accum (append (list form) (list accum))))) 26 accum)) 27 28 (defun encode-json-boolean (key val) 29 (json:as-object-member (key) (format json:*json-output* (if val "true" "false")))) 30 31 (defun encode-json-array (key list) 32 (json:as-object-member (key) 33 (json:with-array () 34 (dolist (elem list) 35 (json:encode-array-member elem))))) 36 37 (defun sassoc (key alist) 38 (assoc key alist :test (typecase key 39 (string #'string=) 40 (t #'eql)))) 41 42 (defun assoc-val (key alist) 43 (cdr (sassoc key alist))) 44 45 ;;; The function below is derived from CL-JSON:LISP-TO-CAMEL-CASE. 46 ;;; All code from CL-JSON is MIT licensed: 47 ;;; 48 ;;; Copyright (c) 2006-2012 Henrik Hjelte 49 ;;; Copyright (c) 2008 Hans Hübner (code from the program YASON) 50 ;;; 51 ;;; Permission is hereby granted, free of charge, to any person obtaining 52 ;;; a copy of this software and associated documentation files (the 53 ;;; "Software"), to deal in the Software without restriction, including 54 ;;; without limitation the rights to use, copy, modify, merge, publish, 55 ;;; distribute, sublicense, and/or sell copies of the Software, and to 56 ;;; permit persons to whom the Software is furnished to do so, subject to 57 ;;; the following conditions: 58 ;;; 59 ;;; The above copyright notice and this permission notice shall be 60 ;;; included in all copies or substantial portions of the Software. 61 ;;; 62 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 63 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 64 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 65 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 66 ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 67 ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 68 ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 69 ;;; 70 ;;; Revisions are licensed as the rest of the package, see LICENSE at the root. 71 (defun lisp-to-cdn-case (string) 72 "Take a string with Lisp-style hyphenation as generated by CL-JSON:CAMEL-CASE-TO-LISP and 73 convert it back to camel case as consumed by Digital Ocean. WARNING: Stupid." 74 (loop with i = 0 and l = (length string) 75 with cc-string = (make-string l) and cc-i = 0 76 with init = t and cap = nil and all-caps = nil 77 while (< i l) 78 do (let ((c (aref string i))) 79 (unless (case c 80 (#\* (if init (setq cap t))) 81 (#\+ (cond 82 (all-caps (setq all-caps nil init t)) 83 (init (setq all-caps t)))) 84 (#\- (progn 85 (setq init t) 86 (cond 87 ((or all-caps 88 (and (< (1+ i) l) 89 (char= (aref string (1+ i)) #\-) 90 (incf i))) 91 (setf (aref cc-string cc-i) #\_) 92 (incf cc-i)) 93 (t 94 (setf (aref cc-string cc-i) #\-) 95 (incf cc-i) 96 (setq cap t)))))) 97 (setf (aref cc-string cc-i) 98 (if (and (or cap all-caps) (alpha-char-p c)) 99 (char-upcase c) 100 (char-downcase c))) 101 (incf cc-i) 102 (setq cap nil init nil)) 103 (incf i)) 104 finally (return (subseq cc-string 0 cc-i))))