| author |
Steve Losh <steve@stevelosh.com> |
| date |
Thu, 12 Jan 2017 10:42:36 +0000 |
| parents |
f31f114d1e79 |
| children |
9a223fdf9928 |
;;;; This file was automatically generated by Quickutil.
;;;; See http://quickutil.org for details.
;;;; To regenerate:
;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :FLIP :MKSTR :ONCE-ONLY :RCURRY :RIFFLE :SPLIT-SEQUENCE :SYMB :WITH-GENSYMS) :ensure-package T :package "CHANCERY.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "CHANCERY.QUICKUTILS")
(defpackage "CHANCERY.QUICKUTILS"
(:documentation "Package that contains Quickutil utility functions.")
(:use #:cl))))
(in-package "CHANCERY.QUICKUTILS")
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
:CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH
:ENSURE-LIST :FLIP :MKSTR :ONCE-ONLY
:RCURRY :RIFFLE :SPLIT-SEQUENCE :SYMB
: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 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 ensure-boolean (x)
"Convert `x` into a Boolean value."
(and x t))
(defmacro ensure-gethash (key hash-table &optional default)
"Like `gethash`, but if `key` is not found in the `hash-table` saves the `default`
under key before returning it. Secondary return value is true if key was
already in the table."
`(multiple-value-bind (value ok) (gethash ,key ,hash-table)
(if ok
(values value ok)
(values (setf (gethash ,key ,hash-table) ,default) nil))))
(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 flip (f)
"Return a function whose argument order of a binary function `f` is reversed."
#'(lambda (y x)
(funcall f x y)))
(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 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 riffle (list obj)
"Insert the item `obj` in between each element of `list`."
(loop :for (x . xs) :on list
:collect x
:when xs
:collect obj))
(defun split-from-end (position-fn sequence start end count remove-empty-subseqs)
(loop
:for right := end :then left
:for left := (max (or (funcall position-fn sequence right) -1)
(1- start))
:unless (and (= right (1+ left))
remove-empty-subseqs) ; empty subseq we don't want
:if (and count (>= nr-elts count))
;; We can't take any more. Return now.
:return (values (nreverse subseqs) right)
:else
:collect (subseq sequence (1+ left) right) into subseqs
:and :sum 1 :into nr-elts
:until (< left start)
:finally (return (values (nreverse subseqs) (1+ left)))))
(defun split-from-start (position-fn sequence start end count remove-empty-subseqs)
(let ((length (length sequence)))
(loop
:for left := start :then (+ right 1)
:for right := (min (or (funcall position-fn sequence left) length)
end)
:unless (and (= right left)
remove-empty-subseqs) ; empty subseq we don't want
:if (and count (>= nr-elts count))
;; We can't take any more. Return now.
:return (values subseqs left)
:else
:collect (subseq sequence left right) :into subseqs
:and :sum 1 :into nr-elts
:until (>= right end)
:finally (return (values subseqs right)))))
(macrolet ((check-bounds (sequence start end)
(let ((length (gensym (string '#:length))))
`(let ((,length (length ,sequence)))
(check-type ,start unsigned-byte "a non-negative integer")
(when ,end (check-type ,end unsigned-byte "a non-negative integer or NIL"))
(unless ,end
(setf ,end ,length))
(unless (<= ,start ,end ,length)
(error "Wrong sequence bounds. start: ~S end: ~S" ,start ,end))))))
(defun split-sequence (delimiter sequence &key (start 0) (end nil) (from-end nil)
(count nil) (remove-empty-subseqs nil)
(test #'eql) (test-not nil) (key #'identity))
"Return a list of subsequences in seq delimited by delimiter.
If :remove-empty-subseqs is NIL, empty subsequences will be included
in the result; otherwise they will be discarded. All other keywords
work analogously to those for CL:SUBSTITUTE. In particular, the
behaviour of :from-end is possibly different from other versions of
this function; :from-end values of NIL and T are equivalent unless
:count is supplied. The second return value is an index suitable as an
argument to CL:SUBSEQ into the sequence indicating where processing
stopped."
(check-bounds sequence start end)
(cond
((and (not from-end) (null test-not))
(split-from-start (lambda (sequence start)
(position delimiter sequence :start start :key key :test test))
sequence start end count remove-empty-subseqs))
((and (not from-end) test-not)
(split-from-start (lambda (sequence start)
(position delimiter sequence :start start :key key :test-not test-not))
sequence start end count remove-empty-subseqs))
((and from-end (null test-not))
(split-from-end (lambda (sequence end)
(position delimiter sequence :end end :from-end t :key key :test test))
sequence start end count remove-empty-subseqs))
((and from-end test-not)
(split-from-end (lambda (sequence end)
(position delimiter sequence :end end :from-end t :key key :test-not test-not))
sequence start end count remove-empty-subseqs))))
(defun split-sequence-if (predicate sequence &key (start 0) (end nil) (from-end nil)
(count nil) (remove-empty-subseqs nil) (key #'identity))
"Return a list of subsequences in seq delimited by items satisfying
predicate.
If :remove-empty-subseqs is NIL, empty subsequences will be included
in the result; otherwise they will be discarded. All other keywords
work analogously to those for CL:SUBSTITUTE-IF. In particular, the
behaviour of :from-end is possibly different from other versions of
this function; :from-end values of NIL and T are equivalent unless
:count is supplied. The second return value is an index suitable as an
argument to CL:SUBSEQ into the sequence indicating where processing
stopped."
(check-bounds sequence start end)
(if from-end
(split-from-end (lambda (sequence end)
(position-if predicate sequence :end end :from-end t :key key))
sequence start end count remove-empty-subseqs)
(split-from-start (lambda (sequence start)
(position-if predicate sequence :start start :key key))
sequence start end count remove-empty-subseqs)))
(defun split-sequence-if-not (predicate sequence &key (count nil) (remove-empty-subseqs nil)
(from-end nil) (start 0) (end nil) (key #'identity))
"Return a list of subsequences in seq delimited by items satisfying
\(CL:COMPLEMENT predicate).
If :remove-empty-subseqs is NIL, empty subsequences will be included
in the result; otherwise they will be discarded. All other keywords
work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular,
the behaviour of :from-end is possibly different from other versions
of this function; :from-end values of NIL and T are equivalent unless
:count is supplied. The second return value is an index suitable as an
argument to CL:SUBSEQ into the sequence indicating where processing
stopped."
(check-bounds sequence start end)
(if from-end
(split-from-end (lambda (sequence end)
(position-if-not predicate sequence :end end :from-end t :key key))
sequence start end count remove-empty-subseqs)
(split-from-start (lambda (sequence start)
(position-if-not predicate sequence :start start :key key))
sequence start end count remove-empty-subseqs))))
(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))))
(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 '(curry ensure-boolean ensure-gethash ensure-list flip mkstr
once-only rcurry riffle split-sequence split-sequence-if
split-sequence-if-not symb with-gensyms with-unique-names)))
;;;; END OF quickutils.lisp ;;;;