| author |
Steve Losh <steve@stevelosh.com> |
| date |
Tue, 30 Apr 2019 17:06:46 -0400 |
| parents |
280b721cfa9f |
| children |
(none) |
;;;; This file was automatically generated by Quickutil.
;;;; See http://quickutil.org for details.
;;;; To regenerate:
;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :EMPTYP :ENSURE-KEYWORD :ENSURE-LIST :FLATTEN :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAKE-GENSYM :MAP-TREE :MKSTR :ONCE-ONLY :PARSE-BODY :RANGE :RCURRY :SYMB :WEAVE :WITH-GENSYMS) :ensure-package T :package "LOSH.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "LOSH.QUICKUTILS")
(defpackage "LOSH.QUICKUTILS"
(:documentation "Package that contains Quickutil utility functions.")
(:use #:cl))))
(in-package "LOSH.QUICKUTILS")
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
:COMPOSE :COPY-HASH-TABLE :CURRY
:NON-ZERO-P :EMPTYP :ENSURE-KEYWORD
:ENSURE-LIST :FLATTEN
:HASH-TABLE-ALIST :MAPHASH-KEYS
:HASH-TABLE-KEYS :MAPHASH-VALUES
:HASH-TABLE-VALUES :MAKE-GENSYM
:MAP-TREE :MKSTR :ONCE-ONLY
:PARSE-BODY :RANGE :RCURRY :SYMB
:WEAVE :STRING-DESIGNATOR
:WITH-GENSYMS))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun make-gensym-list (length &optional (x "G"))
"Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
using the second (optional, defaulting to `\"G\"`) argument."
(let ((g (if (typep x '(integer 0)) x (string x))))
(loop repeat length
collect (gensym g))))
) ; eval-when
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; To propagate return type and allow the compiler to eliminate the IF when
;;; it is known if the argument is function or not.
(declaim (inline ensure-function))
(declaim (ftype (function (t) (values function &optional))
ensure-function))
(defun ensure-function (function-designator)
"Returns the function designated by `function-designator`:
if `function-designator` is a function, it is returned, otherwise
it must be a function name and its `fdefinition` is returned."
(if (functionp function-designator)
function-designator
(fdefinition function-designator)))
) ; eval-when
(defun compose (function &rest more-functions)
"Returns a function composed of `function` and `more-functions` that applies its ;
arguments to to each in turn, starting from the rightmost of `more-functions`,
and then calling the next one with the primary value of the last."
(declare (optimize (speed 3) (safety 1) (debug 1)))
(reduce (lambda (f g)
(let ((f (ensure-function f))
(g (ensure-function g)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
(funcall f (apply g arguments)))))
more-functions
:initial-value function))
(define-compiler-macro compose (function &rest more-functions)
(labels ((compose-1 (funs)
(if (cdr funs)
`(funcall ,(car funs) ,(compose-1 (cdr funs)))
`(apply ,(car funs) arguments))))
(let* ((args (cons function more-functions))
(funs (make-gensym-list (length args) "COMPOSE")))
`(let ,(loop for f in funs for arg in args
collect `(,f (ensure-function ,arg)))
(declare (optimize (speed 3) (safety 1) (debug 1)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
,(compose-1 funs))))))
(defun copy-hash-table (table &key key test size
rehash-size rehash-threshold)
"Returns a copy of hash table `table`, with the same keys and values
as the `table`. The copy has the same properties as the original, unless
overridden by the keyword arguments.
Before each of the original values is set into the new hash-table, `key`
is invoked on the value. As `key` defaults to `cl:identity`, a shallow
copy is returned by default."
(setf key (or key 'identity))
(setf test (or test (hash-table-test table)))
(setf size (or size (hash-table-size table)))
(setf rehash-size (or rehash-size (hash-table-rehash-size table)))
(setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold table)))
(let ((copy (make-hash-table :test test :size size
:rehash-size rehash-size
:rehash-threshold rehash-threshold)))
(maphash (lambda (k v)
(setf (gethash k copy) (funcall key v)))
table)
copy))
(defun curry (function &rest arguments)
"Returns a function that applies `arguments` and the arguments
it is called with to `function`."
(declare (optimize (speed 3) (safety 1) (debug 1)))
(let ((fn (ensure-function function)))
(lambda (&rest more)
(declare (dynamic-extent more))
;; Using M-V-C we don't need to append the arguments.
(multiple-value-call fn (values-list arguments) (values-list more)))))
(define-compiler-macro curry (function &rest arguments)
(let ((curries (make-gensym-list (length arguments) "CURRY"))
(fun (gensym "FUN")))
`(let ((,fun (ensure-function ,function))
,@(mapcar #'list curries arguments))
(declare (optimize (speed 3) (safety 1) (debug 1)))
(lambda (&rest more)
(apply ,fun ,@curries more)))))
(defun non-zero-p (n)
"Check if `n` is non-zero."
(not (zerop n)))
(defgeneric emptyp (object)
(:documentation "Determine if `object` is empty.")
(:method ((x null)) t)
(:method ((x cons)) nil)
(:method ((x vector)) (zerop (length x))) ; STRING :< VECTOR
(:method ((x array)) (notany #'non-zero-p (array-dimensions x)))
(:method ((x hash-table)) (zerop (hash-table-count x))))
(defun ensure-keyword (x)
"Ensure that a keyword is returned for the string designator `x`."
(values (intern (string x) :keyword)))
(defun ensure-list (list)
"If `list` is a list, it is returned. Otherwise returns the list designated by `list`."
(if (listp list)
list
(list list)))
(defun flatten (&rest xs)
"Flatten (and append) all lists `xs` completely."
(labels ((rec (xs acc)
(cond ((null xs) acc)
((consp xs) (rec (car xs) (rec (cdr xs) acc)))
(t (cons xs acc)))))
(rec xs nil)))
(defun hash-table-alist (table)
"Returns an association list containing the keys and values of hash table
`table`."
(let ((alist nil))
(maphash (lambda (k v)
(push (cons k v) alist))
table)
alist))
(declaim (inline maphash-keys))
(defun maphash-keys (function table)
"Like `maphash`, but calls `function` with each key in the hash table `table`."
(maphash (lambda (k v)
(declare (ignore v))
(funcall function k))
table))
(defun hash-table-keys (table)
"Returns a list containing the keys of hash table `table`."
(let ((keys nil))
(maphash-keys (lambda (k)
(push k keys))
table)
keys))
(declaim (inline maphash-values))
(defun maphash-values (function table)
"Like `maphash`, but calls `function` with each value in the hash table `table`."
(maphash (lambda (k v)
(declare (ignore k))
(funcall function v))
table))
(defun hash-table-values (table)
"Returns a list containing the values of hash table `table`."
(let ((values nil))
(maphash-values (lambda (v)
(push v values))
table)
values))
(defun make-gensym (name)
"If `name` is a non-negative integer, calls `gensym` using it. Otherwise `name`
must be a string designator, in which case calls `gensym` using the designated
string as the argument."
(gensym (if (typep name '(integer 0))
name
(string name))))
(defun map-tree (function tree)
"Map `function` to each of the leave of `tree`."
(check-type tree cons)
(labels ((rec (tree)
(cond
((null tree) nil)
((atom tree) (funcall function tree))
((consp tree)
(cons (rec (car tree))
(rec (cdr tree)))))))
(rec tree)))
(defun mkstr (&rest args)
"Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
Extracted from _On Lisp_, chapter 4."
(with-output-to-string (s)
(dolist (a args) (princ a s))))
(defmacro once-only (specs &body forms)
"Evaluates `forms` with symbols specified in `specs` rebound to temporary
variables, ensuring that each initform is evaluated only once.
Each of `specs` must either be a symbol naming the variable to be rebound, or of
the form:
(symbol initform)
Bare symbols in `specs` are equivalent to
(symbol symbol)
Example:
(defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
(let ((y 0)) (cons1 (incf y))) => (1 . 1)"
(let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
(names-and-forms (mapcar (lambda (spec)
(etypecase spec
(list
(destructuring-bind (name form) spec
(cons name form)))
(symbol
(cons spec spec))))
specs)))
;; bind in user-macro
`(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
gensyms names-and-forms)
;; bind in final expansion
`(let (,,@(mapcar (lambda (g n)
``(,,g ,,(cdr n)))
gensyms names-and-forms))
;; bind in user-macro
,(let ,(mapcar (lambda (n g) (list (car n) g))
names-and-forms gensyms)
,@forms)))))
(defun parse-body (body &key documentation whole)
"Parses `body` into `(values remaining-forms declarations doc-string)`.
Documentation strings are recognized only if `documentation` is true.
Syntax errors in body are signalled and `whole` is used in the signal
arguments when given."
(let ((doc nil)
(decls nil)
(current nil))
(tagbody
:declarations
(setf current (car body))
(when (and documentation (stringp current) (cdr body))
(if doc
(error "Too many documentation strings in ~S." (or whole body))
(setf doc (pop body)))
(go :declarations))
(when (and (listp current) (eql (first current) 'declare))
(push (pop body) decls)
(go :declarations)))
(values body (nreverse decls) doc)))
(defun range (start end &key (step 1) (key 'identity))
"Return the list of numbers `n` such that `start <= n < end` and
`n = start + k*step` for suitable integers `k`. If a function `key` is
provided, then apply it to each number."
(assert (<= start end))
(loop :for i :from start :below end :by step :collecting (funcall key i)))
(defun rcurry (function &rest arguments)
"Returns a function that applies the arguments it is called
with and `arguments` to `function`."
(declare (optimize (speed 3) (safety 1) (debug 1)))
(let ((fn (ensure-function function)))
(lambda (&rest more)
(declare (dynamic-extent more))
(multiple-value-call fn (values-list more) (values-list arguments)))))
(defun symb (&rest args)
"Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol.
Extracted from _On Lisp_, chapter 4.
See also: `symbolicate`"
(values (intern (apply #'mkstr args))))
(defun weave (&rest lists)
"Return a list whose elements alternate between each of the lists
`lists`. Weaving stops when any of the lists has been exhausted."
(apply #'mapcan #'list lists))
(deftype string-designator ()
"A string designator type. A string designator is either a string, a symbol,
or a character."
`(or symbol string character))
(defmacro with-gensyms (names &body forms)
"Binds each variable named by a symbol in `names` to a unique symbol around
`forms`. Each of `names` must either be either a symbol, or of the form:
(symbol string-designator)
Bare symbols appearing in `names` are equivalent to:
(symbol symbol)
The string-designator is used as the argument to `gensym` when constructing the
unique symbol the named variable will be bound to."
`(let ,(mapcar (lambda (name)
(multiple-value-bind (symbol string)
(etypecase name
(symbol
(values name (symbol-name name)))
((cons symbol (cons string-designator null))
(values (first name) (string (second name)))))
`(,symbol (gensym ,string))))
names)
,@forms))
(defmacro with-unique-names (names &body forms)
"Binds each variable named by a symbol in `names` to a unique symbol around
`forms`. Each of `names` must either be either a symbol, or of the form:
(symbol string-designator)
Bare symbols appearing in `names` are equivalent to:
(symbol symbol)
The string-designator is used as the argument to `gensym` when constructing the
unique symbol the named variable will be bound to."
`(with-gensyms ,names ,@forms))
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(compose copy-hash-table curry emptyp ensure-keyword ensure-list
flatten hash-table-alist hash-table-keys hash-table-values
make-gensym map-tree mkstr once-only parse-body range rcurry symb
weave with-gensyms with-unique-names)))
;;;; END OF quickutils.lisp ;;;;