src/utils.lisp

   1 (uiop:define-package #:lw2.utils
   2   (:use #:cl #:alexandria)
   3   (:export #:alist #:get-unix-time #:substring #:to-boolean #:map-plist #:alist-bind #:list-cond)
   4   (:recycle #:lw2-viewer))
   5
   6 (in-package #:lw2.utils)
   7
   8 (declaim (inline alist))
   9 (defun alist (&rest parms) (plist-alist parms))
  10
  11 (defun get-unix-time ()
  12   (- (get-universal-time) #.(encode-universal-time 0 0 0 1 1 1970 0)))
  13
  14 (deftype array-dimension-type () `(integer 0 ,(- array-dimension-limit 1)))
  15
  16 (declaim (inline substring)
  17          (ftype (function (string array-dimension-type &optional array-dimension-type) string) substring))
  18 (defun substring (string start &optional (end (length string)))
  19   (make-array (- end start) :element-type 'character :displaced-to string :displaced-index-offset start))
  20
  21 (declaim (inline to-boolean))
  22 (defun to-boolean (value)
  23   (and value t))
  24
  25 (defun map-plist (fn plist)
  26   (loop for (key val . rest) = plist then rest
  27         while key
  28         nconc (funcall fn key val)))
  29
  30 (defmacro alist-bind (bindings alist &body body)
  31   "Binds elements of ALIST so they can be used as if they were lexical variables.
  32
  33 Syntax: alist-bind (binding-entry*) alist forms*
  34 => result*
  35 binding-entry ::= (variable-name &optional type alist-key)
  36
  37 Each VARIABLE-NAME is bound to the corresponding datum in ALIST. Modifying these
  38 bindings with SETF will also update the ALIST.
  39 TYPE: type designator, not evaluated.
  40 ALIST-KEY: the alist key, as in the first argument to ASSOC. If it is not
  41 specified, the KEYWORD symbol with the same name as VARIABLE-NAME is used."
  42   (once-only (alist)
  43     (let ((inner-bindings (loop for x in bindings collect
  44                                 (destructuring-bind (bind &optional type key) (if (consp x) x (list x))
  45                                   (list (gensym (string bind)) (gensym (string bind)) (gensym (string bind)) bind (or type t) (or key (intern (string bind) '#:keyword)))))))
  46       (macrolet ((inner-loop (&body body)
  47                    `(loop for (fn-gensym cons-gensym value-gensym bind type key) in inner-bindings collect
  48                           (progn fn-gensym cons-gensym value-gensym bind type key ,@body))))
  49         `(let* (,@(inner-loop `(,cons-gensym (assoc ,key ,alist)))
  50                 ,@(inner-loop `(,value-gensym (cdr ,cons-gensym))))
  51              (declare ,@(inner-loop `(type ,type ,value-gensym)))
  52              (flet (,@(inner-loop `(,fn-gensym () ,value-gensym))
  53                     ,@(inner-loop `((setf ,fn-gensym) (new) (setf (cdr ,cons-gensym) new ,value-gensym new))))
  54                (declare (inline ,@(inner-loop fn-gensym)))
  55                (symbol-macrolet ,(inner-loop `(,bind (,fn-gensym)))
  56                  ,@body)))))))
  57
  58 (defmacro list-cond (&body clauses)
  59   (labels ((expand (clauses)
  60              (when clauses
  61                (destructuring-bind (predicate-form data-form &optional value-form) (first clauses)
  62                  (with-gensyms (predicate value rest)
  63                    `(let* ((,predicate ,predicate-form)
  64                            (,value (if ,predicate ,(if value-form `(cons ,data-form ,value-form) data-form)))
  65                            (,rest ,(expand (rest clauses))))
  66                       (declare (dynamic-extent ,predicate))
  67                       (if ,predicate
  68                           (cons ,value ,rest)
  69                           ,rest)))))))
  70     (expand clauses)))