From 4b2b419400834ba82aae957b73f273e68eb4a669 Mon Sep 17 00:00:00 2001 From: Benjamin Sinkula Date: Thu, 15 Oct 2020 16:30:16 -0500 Subject: [PATCH] Add Common Lisp syntax highlighting test files --- .../syntax-tests/highlighted/Lisp/utils.lisp | 80 +++++++++++++++++++ tests/syntax-tests/source/Lisp/LICENSE.md | 24 ++++++ tests/syntax-tests/source/Lisp/utils.lisp | 80 +++++++++++++++++++ 3 files changed, 184 insertions(+) create mode 100644 tests/syntax-tests/highlighted/Lisp/utils.lisp create mode 100644 tests/syntax-tests/source/Lisp/LICENSE.md create mode 100644 tests/syntax-tests/source/Lisp/utils.lisp diff --git a/tests/syntax-tests/highlighted/Lisp/utils.lisp b/tests/syntax-tests/highlighted/Lisp/utils.lisp new file mode 100644 index 00000000..ef61a820 --- /dev/null +++ b/tests/syntax-tests/highlighted/Lisp/utils.lisp @@ -0,0 +1,80 @@ +(cl:defpackage :chillax.utils + (:use :cl :alexandria) + (:export + :fun :mkhash :hashget :strcat :dequote :at)) +(in-package :chillax.utils) + +;;; Functions +(defmacro fun (&body body) + "This macro puts the FUN back in FUNCTION." + `(lambda (&optional _) (declare (ignorable _)) ,@body)) + +;;; Hash tables +(defun mkhash (&rest keys-and-values &aux (table (make-hash-table :test #'equal))) + "Convenience function for `literal' hash table definition." + (loop for (key val) on keys-and-values by #'cddr do (setf (gethash key table) val) + finally (return table))) + +(defun hashget (hash &rest keys) + "Convenience function for recursively accessing hash tables." + (reduce (lambda (h k) (gethash k h)) keys :initial-value hash)) + +(define-compiler-macro hashget (hash &rest keys) + (if (null keys) hash + (let ((hash-sym (make-symbol "HASH")) + (key-syms (loop for i below (length keys) + collect (make-symbol (format nil "~:@(~:R~)-KEY" i))))) + `(let ((,hash-sym ,hash) + ,@(loop for key in keys for sym in key-syms + collect `(,sym ,key))) + ,(reduce (lambda (hash key) `(gethash ,key ,hash)) + key-syms :initial-value hash-sym))))) + +(defun (setf hashget) (new-value hash key &rest more-keys) + "Uses the last key given to hashget to insert NEW-VALUE into the hash table +returned by the second-to-last key. +tl;dr: DWIM SETF function for HASHGET." + (if more-keys + (setf (gethash (car (last more-keys)) + (apply #'hashget hash key (butlast more-keys))) + new-value) + (setf (gethash key hash) new-value))) + +;;; Strings +(defun strcat (string &rest more-strings) + (apply #'concatenate 'string string more-strings)) + +(defun dequote (string) + (let ((len (length string))) + (if (and (> len 1) (starts-with #\" string) (ends-with #\" string)) + (subseq string 1 (- len 1)) + string))) + +;;; +;;; At +;;; +(defgeneric at (doc &rest keys)) +(defgeneric (setf at) (new-value doc key &rest more-keys)) + +(defmethod at ((doc hash-table) &rest keys) + (apply #'hashget doc keys)) +(defmethod (setf at) (new-value (doc hash-table) key &rest more-keys) + (apply #'(setf hashget) new-value doc key more-keys)) + +(defmethod at ((doc list) &rest keys) + (reduce (lambda (alist key) + (cdr (assoc key alist :test #'equal))) + keys :initial-value doc)) +(defmethod (setf at) (new-value (doc list) key &rest more-keys) + (if more-keys + (setf (cdr (assoc (car (last more-keys)) + (apply #'at doc key (butlast more-keys)) + :test #'equal)) + new-value) + (setf (cdr (assoc key doc :test #'equal)) new-value))) + +;; A playful alias. +(defun @ (doc &rest keys) + (apply #'at doc keys)) +(defun (setf @) (new-value doc key &rest more-keys) + (apply #'(setf at) new-value doc key more-keys)) diff --git a/tests/syntax-tests/source/Lisp/LICENSE.md b/tests/syntax-tests/source/Lisp/LICENSE.md new file mode 100644 index 00000000..9da63d32 --- /dev/null +++ b/tests/syntax-tests/source/Lisp/LICENSE.md @@ -0,0 +1,24 @@ +The `utils.lisp` file has been added from https://github.com/zkat/chillax under the following license: + +Copyright © 2009-2010 Kat Marchán + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, copy, +modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + diff --git a/tests/syntax-tests/source/Lisp/utils.lisp b/tests/syntax-tests/source/Lisp/utils.lisp new file mode 100644 index 00000000..91a76ae5 --- /dev/null +++ b/tests/syntax-tests/source/Lisp/utils.lisp @@ -0,0 +1,80 @@ +(cl:defpackage :chillax.utils + (:use :cl :alexandria) + (:export + :fun :mkhash :hashget :strcat :dequote :at)) +(in-package :chillax.utils) + +;;; Functions +(defmacro fun (&body body) + "This macro puts the FUN back in FUNCTION." + `(lambda (&optional _) (declare (ignorable _)) ,@body)) + +;;; Hash tables +(defun mkhash (&rest keys-and-values &aux (table (make-hash-table :test #'equal))) + "Convenience function for `literal' hash table definition." + (loop for (key val) on keys-and-values by #'cddr do (setf (gethash key table) val) + finally (return table))) + +(defun hashget (hash &rest keys) + "Convenience function for recursively accessing hash tables." + (reduce (lambda (h k) (gethash k h)) keys :initial-value hash)) + +(define-compiler-macro hashget (hash &rest keys) + (if (null keys) hash + (let ((hash-sym (make-symbol "HASH")) + (key-syms (loop for i below (length keys) + collect (make-symbol (format nil "~:@(~:R~)-KEY" i))))) + `(let ((,hash-sym ,hash) + ,@(loop for key in keys for sym in key-syms + collect `(,sym ,key))) + ,(reduce (lambda (hash key) `(gethash ,key ,hash)) + key-syms :initial-value hash-sym))))) + +(defun (setf hashget) (new-value hash key &rest more-keys) + "Uses the last key given to hashget to insert NEW-VALUE into the hash table +returned by the second-to-last key. +tl;dr: DWIM SETF function for HASHGET." + (if more-keys + (setf (gethash (car (last more-keys)) + (apply #'hashget hash key (butlast more-keys))) + new-value) + (setf (gethash key hash) new-value))) + +;;; Strings +(defun strcat (string &rest more-strings) + (apply #'concatenate 'string string more-strings)) + +(defun dequote (string) + (let ((len (length string))) + (if (and (> len 1) (starts-with #\" string) (ends-with #\" string)) + (subseq string 1 (- len 1)) + string))) + +;;; +;;; At +;;; +(defgeneric at (doc &rest keys)) +(defgeneric (setf at) (new-value doc key &rest more-keys)) + +(defmethod at ((doc hash-table) &rest keys) + (apply #'hashget doc keys)) +(defmethod (setf at) (new-value (doc hash-table) key &rest more-keys) + (apply #'(setf hashget) new-value doc key more-keys)) + +(defmethod at ((doc list) &rest keys) + (reduce (lambda (alist key) + (cdr (assoc key alist :test #'equal))) + keys :initial-value doc)) +(defmethod (setf at) (new-value (doc list) key &rest more-keys) + (if more-keys + (setf (cdr (assoc (car (last more-keys)) + (apply #'at doc key (butlast more-keys)) + :test #'equal)) + new-value) + (setf (cdr (assoc key doc :test #'equal)) new-value))) + +;; A playful alias. +(defun @ (doc &rest keys) + (apply #'at doc keys)) +(defun (setf @) (new-value doc key &rest more-keys) + (apply #'(setf at) new-value doc key more-keys))