Download
(require 'cl)
(require 'eieio nil t)
(require 'list-utils nil t)
(declare-function object-p "eieio.el")
(declare-function process-live-p "subr.el")
(declare-function ring-elements "ring.el")
(eval-when-compile
(defvar eieio-unbound))
(unless (fboundp 'process-live-p)
(defun process-live-p (process)
"Returns non-nil if PROCESS is alive.
A process is considered alive if its status is `run', `open',
`listen', `connect' or `stop'."
(memq (process-status process)
'(run open listen connect stop))))
(defun truthy (obj &optional shallow length)
"Return non-nil if OBJ has \"truthiness\".
Whereas Lisp considers any non-nil value to be \"true\" when
evaluating a Boolean condition, `truthy' considers a value to be
\"truthy\" if it has *content*.
When OBJ has \"truthiness\", `truthy' returns OBJ, otherwise
nil.
If OBJ is a constant or symbol other than nil, it is always truthy.
If OBJ is a number, it must be non-zero.
If OBJ is a hash table, it must have keys.
If OBJ is a function or a macro, it must have a body containing
at least one truthy value.
If OBJ is compiled byte-code, it must have a body.
If OBJ is a keymap, it must have defined keys.
If OBJ is a char-table, it must have keys as returned by
`map-char-table'.
If OBJ is a abbrev-table, it must have at least one value.
If OBJ is a defstruct or EIEIO object, at least one slot must
contain a truthy value.
If OBJ is a ring, it must contain at least one truthy element.
If OBJ is a string, it must have length greater than zero.
If OBJ is a sequence, if must contain at least one truthy
value.
If OBJ is a marker or overlay, it must be associated
with a buffer and have a position.
If OBJ is a buffer, it must be live and of non-zero length.
If OBJ is a frame, window, or process, it must be live, according
to (eg) `window-live-p'.
If OBJ is a font, at least one property of the font must be
specified.
When optional SHALLOW is non-nil, recursive considerations
do not examine truthiness, simply whether constituent elements
are non-nil. Therefore
(truthy '(0 0 0 0))
returns nil, because no truthy element is found in the list. But
(truthy '(0 0 0 0) 'shallow)
returns OBJ, because the list holds non-nil elements.
The function `truthy-s' is provided as shorthand for
\(truthy OBJ 'shallow\).
When optional LENGTH is non-nil, OBJ is always truthy if the
concept of length can be applied to it and OBJ has non-zero
length, considering only the portion of the data type which may
vary in length. If the concept of length cannot be applied to
OBJ, the usual rules apply. So
(truthy '(nil nil) nil 'length)
has length and returns OBJ. And eg
(truthy (lambda (args)))
has no length (because the lambda has no body) and returns nil.
For a ring or object, the \"lengthwise\" test can check whether
any slots have been filled. For a struct it is not possible to
distinguish between unfilled slots and slots filled with nil, so
the lengthwise test succeeds if there is a non-zero number of
slots.
The function `truthy-l' is provided as shorthand for
\(truthy OBJ nil 'length\)."
(cond
((null obj)
nil)
((and (vectorp obj)
(= 0 (length obj)))
nil)
((symbolp obj)
obj)
((and (vectorp obj)
(symbolp (aref obj 0))
(string-match-p "\\`cl-" (symbol-name (aref obj 0))))
(catch 'truthy
(dolist (elt (append (subseq obj 1 (length obj)) nil))
(when (or length
(and shallow elt)
(truthy elt))
(throw 'truthy obj)))
nil))
((byte-code-function-p obj)
(when (aref obj 1)
obj))
((ring-p obj)
(catch 'truthy
(dolist (elt (ring-elements obj))
(when (or length
(and shallow elt)
(truthy elt))
(throw 'truthy obj)))
nil))
((and (listp obj)
(eq 'macro (car obj))
(functionp (cdr obj)))
(catch 'truthy
(dolist (elt (cdddr obj))
(when (or length
(and shallow elt)
(truthy elt))
(throw 'truthy obj)))
nil))
((functionp obj)
(catch 'truthy
(dolist (elt (cddr obj))
(when (or length
(and shallow elt)
(truthy elt))
(throw 'truthy obj)))
nil))
((frame-configuration-p obj)
(catch 'truthy
(dolist (elt (cdr obj))
(when (or length
(and shallow elt)
(truthy elt))
(throw 'truthy obj)))
nil))
((keymapp obj)
(catch 'truthy
(dolist (elt (cdr obj))
(when (or length
(and shallow elt)
(truthy elt))
(throw 'truthy obj)))
nil))
((numberp obj)
(when (/= 0 obj)
obj))
((bufferp obj)
(when (and (buffer-live-p obj)
(> (with-current-buffer obj (point-max)) 1))
obj))
((framep obj)
(when (frame-live-p obj)
obj))
((windowp obj)
(when (window-live-p obj)
obj))
((markerp obj)
(when (and (marker-buffer obj)
(marker-position obj))
obj))
((overlayp obj)
(when (and (overlay-buffer obj)
(overlay-start obj)
(overlay-end obj)
(or (not length)
(/= (overlay-start obj)
(overlay-end obj))))
obj))
((processp obj)
(when (process-live-p obj)
obj))
((and (fboundp 'object-p)
(object-p obj))
(catch 'truthy
(dolist (elt (remq eieio-unbound (append (subseq obj 3 (length obj)) nil)))
(when (or length
(and shallow elt)
(truthy elt))
(throw 'truthy obj)))
nil))
((fontp obj)
(catch 'truthy
(dolist (k '(:family :weight :slant :width :foundry :adstyle :registry :size :name :script :otf))
(when (font-get obj k)
(throw 'truthy obj)))
nil))
((ignore-errors (abbrev-table-p obj))
(catch 'truthy
(mapatoms #'(lambda (sym)
(when (> (length (symbol-name sym)) 0)
(throw 'truthy obj))) obj)
nil))
((hash-table-p obj)
(catch 'truthy
(maphash #'(lambda (k v)
(throw 'truthy obj))
obj)
nil))
((char-table-p obj)
(catch 'truthy
(map-char-table #'(lambda (k v)
(throw 'truthy obj))
obj)
nil))
((stringp obj)
(when (> (length obj) 0)
obj))
((listp obj)
(let* ((measurer (if (fboundp 'list-utils-safe-length) 'list-utils-safe-length 'safe-length))
(len (funcall measurer obj)))
(cond
((and (consp obj)
(> len 0)
(not (listp (nthcdr len obj))))
(when (or length
shallow
(or (truthy (subseq obj 0 len))
(truthy (nthcdr len obj))))
obj))
(t
(catch 'truthy
(dolist (elt (subseq obj 0 (funcall measurer obj)))
(when (or length
(and shallow elt)
(truthy elt))
(throw 'truthy obj)))
nil)))))
((sequencep obj)
(catch 'truthy
(dolist (elt (mapcar 'identity (append obj nil)))
(when (or length
(and shallow elt)
(truthy elt))
(throw 'truthy obj)))
nil))
(t
obj)))
(defun truthy-s (obj)
"Return non-nil if OBJ has shallow \"truthiness\".
This is equivalent to calling `truthy' with the SHALLOW argument
non-nil."
(truthy obj 'shallow))
(defun truthy-l (obj)
"Return non-nil if OBJ has lengthwise \"truthiness\".
This is equivalent to calling `truthy' with the LENGTH argument
non-nil."
(truthy obj nil 'length))
(provide 'truthy)