src/control-flow.lisp @ 861b0bbcb319

Add remhash-* utilities
author Steve Losh <steve@stevelosh.com>
date Tue, 30 Apr 2019 17:06:11 -0400
parents 73c14a96cb0e
children a996dd9ad3eb
(in-package :losh.control-flow)

(defmacro -<> (expr &rest forms)
  "Thread the given forms, with `<>` as a placeholder."
  ;; I am going to lose my fucking mind if I have to program lisp without
  ;; a threading macro, but I don't want to add another dep to this library, so
  ;; here we are.
  `(let* ((<> ,expr)
          ,@(mapcar (lambda (form)
                      (if (symbolp form)
                        `(<> (,form <>))
                        `(<> ,form)))
                    forms))
     <>))

(defmacro nest (&rest forms)
  "Thread the given forms, putting each as the body of the previous.

  Example:

    (nest (multiple-value-bind (a b c) (foo))
          (when (and a b c))
          (multiple-value-bind (d e f) (bar))
          (when (and d e f))
          (do-something))

  macroexpands to:

    (multiple-value-bind (a b c) (foo)
      (when (and a b c)
        (multiple-value-bind (d e f) (bar)
          (when (and d e f)
            (do-something)))))

  "
  ;; thanks, Fare
  (reduce (lambda (prefix body) `(,@prefix ,body))
          forms :from-end t))


(defmacro recursively (bindings &body body)
  "Execute `body` recursively, like Clojure's `loop`/`recur`.

  `bindings` should contain a list of symbols and (optional) starting values.

  In `body` the symbol `recur` will be bound to the function for recurring.

  This macro doesn't perform an explicit tail-recursion check like Clojure's
  `loop`.  You know what you're doing, right?

  Example:

      (defun length (some-list)
        (recursively ((list some-list)
                      (n 0))
          (if (null list)
            n
            (recur (cdr list) (1+ n)))))

  "
  (flet ((extract-var (binding)
           (if (atom binding) binding (first binding)))
         (extract-val (binding)
           (if (atom binding) nil (second binding))))
    `(labels ((recur ,(mapcar #'extract-var bindings)
                ,@body))
      (recur ,@(mapcar #'extract-val bindings)))))


(defmacro when-found ((var lookup-expr) &body body)
  "Perform `body` with `var` bound to the result of `lookup-expr`, when valid.

  `lookup-expr` should be an expression that returns two values, the first being
  the result (which will be bound to `var`) and the second indicating whether
  the lookup was successful.  The standard `gethash` is an example of a function
  that behaves like this.

  If the lookup was successful, `body` will be executed and its value returned.

  Example:

    (multiple-value-bind (val found) (gethash :foo hash)
      (when found
        body))

    ; becomes

    (when-found (val (gethash :foo hash))
      body)

  "
  (with-gensyms (found)
    `(multiple-value-bind (,var ,found) ,lookup-expr
       ;; We could preserve and pass along the value of found as a secondary
       ;; return value from the form, but that would kill potential last-call
       ;; optimization (and the ability to return multiple values from `body`).
       (when ,found
         ,@body))))

(defmacro if-found ((var lookup-expr) then else)
  "Perform `then` or `else` depending on the results of `lookup-expr`.

  `lookup-expr` should be an expression that returns two values, the first being
  the result and the second indicating whether the lookup was successful.  The
  standard `gethash` is an example of a function that behaves like this.

  If the lookup was successful, `then` will be executed with `var` bound to the
  result, and its value returned.

  Otherwise `else` will be executed and returned, without any extra bindings.

  Example:

    (multiple-value-bind (val found) (gethash :foo hash)
      (if found
        'yes
        'no))

    ; becomes

    (if-found (val (gethash :foo hash))
      'yes
      'no)

  "
  (with-gensyms (found result)
    `(multiple-value-bind (,result ,found) ,lookup-expr
      (if ,found
        (let ((,var ,result))
          ,then)
        ,else))))


(defmacro gathering (&body body)
  "Run `body` to gather some things and return a fresh list of them.

  `body` will be executed with the symbol `gather` bound to a function of one
  argument.  Once `body` has finished, a list of everything `gather` was called
  on will be returned.

  It's handy for pulling results out of code that executes procedurally and
  doesn't return anything, like `maphash` or Alexandria's `map-permutations`.

  The `gather` function can be passed to other functions, but should not be
  retained once the `gathering` form has returned (it would be useless to do so
  anyway).

  Examples:

    (gathering
      (dotimes (i 5)
        (gather i))
    =>
    (0 1 2 3 4)

    (gathering
      (mapc #'gather '(1 2 3))
      (mapc #'gather '(a b)))
    =>
    (1 2 3 a b)

  "
  (with-gensyms (result)
    `(let ((,result (make-queue)))
      (flet ((gather (item)
               (enqueue item ,result)
               item))
        ,@body)
      (queue-contents ,result))))

(defmacro gathering-vector (options &body body)
  "Run `body` to gather some things and return a fresh vector of them.

  `body` will be executed with the symbol `gather` bound to a function of one
  argument.  Once `body` has finished, a vector of everything `gather` was
  called on will be returned.  This vector will be adjustable and have a fill
  pointer.

  It's handy for pulling results out of code that executes procedurally and
  doesn't return anything, like `maphash` or Alexandria's `map-permutations`.

  The `gather` function can be passed to other functions, but should not be
  retained once the `gathering` form has returned (it would be useless to do so
  anyway).

  Examples:

    (gathering-vector ()
      (dotimes (i 5)
        (gather i))
    =>
    #(0 1 2 3 4)

    (gathering-vector ()
      (mapc #'gather '(1 2 3))
      (mapc #'gather '(a b)))
    =>
    #(1 2 3 a b)

  "
  (destructuring-bind (&key (size 16) (element-type t))
      options
    (with-gensyms (result)
      `(let ((,result (make-array ,size :adjustable t :fill-pointer 0
                                  :element-type ,element-type)))
         (flet ((gather (item)
                  (vector-push-extend item ,result)
                  item))
           ,@body)
         ,result))))


(defmacro when-let (bindings &body body)
  "Bind `bindings` in parallel and execute `body`, short-circuiting on `nil`.

  This macro combines `when` and `let`.  It takes a list of bindings and binds
  them like `let` before executing `body`, but if any binding's value evaluates
  to `nil` the process stops there and `nil` is immediately returned.

  Examples:

    (when-let ((a (progn (print :a) 1))
               (b (progn (print :b) 2))
               (c (progn (print :c) 3)))
      (list a b c))
    ; =>
    :A
    :B
    :C
    (1 2 3)

    (when-let ((a (progn (print :a) 1))
               (b (progn (print :b) nil))
               (c (progn (print :c) 3)))
      (list a b c))
    ; =>
    :A
    :B
    NIL

  "
  ;; (when-let ((a 1)
  ;;            (b 2))
  ;;   (+ a b))
  ;; =>
  ;; (BLOCK #:BLOCK632
  ;;   (LET ((A (OR 1 (RETURN-FROM #:BLOCK632)))
  ;;         (B (OR 2 (RETURN-FROM #:BLOCK632))))
  ;;     (+ A B)))
  (with-gensyms (block)
    `(block ,block
       (let (,@(loop :for (symbol value) :in bindings
                     :collect `(,symbol (or ,value (return-from ,block)))))
         ,@body))))

(defmacro when-let* (bindings &body body)
  "Bind `bindings` sequentially and execute `body`, short-circuiting on `nil`.

  This macro combines `when` and `let*`.  It takes a list of bindings and binds
  them like `let` before executing `body`, but if any binding's value evaluates
  to `nil` the process stops there and `nil` is immediately returned.

  Examples:

    (when-let* ((a (progn (print :a) 1))
                (b (progn (print :b) 2))
                (c (progn (print :c) 3)))
      (list a b c))
    ; =>
    :A
    :B
    :C
    (1 2 3)

    (when-let* ((a (progn (print :a) 1))
                (b (progn (print :b) nil))
                (c (progn (print :c) 3)))
      (list a b c))
    ; =>
    :A
    :B
    NIL

  "
  ;; (when-let* ((a 1)
  ;;             (b 2))
  ;;      (+ a b))
  ;; =>
  ;; (BLOCK #:BLOCK647
  ;;   (LET* ((A (OR 1 (RETURN-FROM #:BLOCK647)))
  ;;          (B (OR 2 (RETURN-FROM #:BLOCK647))))
  ;;     (+ A B)))
  (with-gensyms (block)
    `(block ,block
       (let* (,@(loop :for (symbol value) :in bindings
                      :collect `(,symbol (or ,value (return-from ,block)))))
         ,@body))))

(defmacro if-let (bindings &body body)
  "Bind `bindings` in parallel and execute `then` if all are true, or `else` otherwise.

  `body` must be of the form `(...optional-declarations... then else)`.

  This macro combines `if` and `let`.  It takes a list of bindings and binds
  them like `let` before executing the `then` branch of `body`, but if any
  binding's value evaluates to `nil` the process stops there and the `else`
  branch is immediately executed (with no bindings in effect).

  If any `optional-declarations` are included they will only be in effect for
  the `then` branch.

  Examples:

    (if-let ((a (progn (print :a) 1))
             (b (progn (print :b) 2))
             (c (progn (print :c) 3)))
      (list a b c)
      'nope)
    ; =>
    :A
    :B
    :C
    (1 2 3)

    (if-let ((a (progn (print :a) 1))
             (b (progn (print :b) nil))
             (c (progn (print :c) 3)))
      (list a b c)
      'nope)
    ; =>
    :A
    :B
    NOPE

  "
  (with-gensyms (outer inner)
    (multiple-value-bind (body declarations) (parse-body body)
      (destructuring-bind (then else) body
        `(block ,outer
           (block ,inner
             (let ,(loop :for (symbol value) :in bindings
                         :collect `(,symbol (or ,value (return-from ,inner))))
               ,@declarations
               (return-from ,outer ,then)))
           ,else)))))

(defmacro if-let* (bindings &body body)
  "Bind `bindings` sequentially and execute `then` if all are true, or `else` otherwise.

  `body` must be of the form `(...optional-declarations... then else)`.

  This macro combines `if` and `let*`.  It takes a list of bindings and binds
  them like `let*` before executing the `then` branch of `body`, but if any
  binding's value evaluate to `nil` the process stops there and the `else`
  branch is immediately executed (with no bindings in effect).

  If any `optional-declarations` are included they will only be in effect for
  the `then` branch.

  Examples:

    (if-let* ((a (progn (print :a) 1))
              (b (progn (print :b) 2))
              (c (progn (print :c) 3)))
      (list a b c)
      'nope)
    ; =>
    :A
    :B
    :C
    (1 2 3)

    (if-let* ((a (progn (print :a) 1))
              (b (progn (print :b) nil))
              (c (progn (print :c) 3)))
      (list a b c)
      'nope)
    ; =>
    :A
    :B
    NOPE

  "
  (with-gensyms (outer inner)
    (multiple-value-bind (body declarations) (parse-body body)
      (destructuring-bind (then else) body
        `(block ,outer
           (block ,inner
             (let* ,(loop :for (symbol value) :in bindings
                          :collect `(,symbol (or ,value (return-from ,inner))))
               ,@declarations
               (return-from ,outer ,then)))
           ,else)))))


(defmacro multiple-value-bind* (bindings &body body)
  "Bind each pair in `bindings` with `multiple-value-bind` sequentially.

  Example:

    (multiple-value-bind*
        (((a b) (values 0 1))
         ((c) (values (1+ b)))
      (list a b c))
    ; =>
    ; (0 1 2)

  From https://github.com/phoe/m-m-v-b

  "
  (if (null bindings)
    `(progn ,@body)
    (destructuring-bind ((vars form) &rest bindings) bindings
      `(multiple-value-bind ,vars ,form
         (multiple-value-bind* ,bindings ,@body)))))


(defmacro do-repeat (n &body body)
  "Perform `body` `n` times."
  `(dotimes (,(gensym) ,n)
     ,@body))

(defmacro do-range (ranges &body body)
  "Perform `body` on the given `ranges`.

  Each range in `ranges` should be of the form `(variable from below)`.  During
  iteration `body` will be executed with `variable` bound to successive values
  in the range [`from`, `below`).

  If multiple ranges are given they will be iterated in a nested fashion.

  Example:

    (do-range ((x  0  3)
               (y 10 12))
      (pr x y))
    ; =>
    ; 0 10
    ; 0 11
    ; 1 10
    ; 1 11
    ; 2 10
    ; 2 11

  "
  (assert (not (null ranges)) ()
    "Ranges to iterate in DO-RANGE must not be null.")
  (recursively ((ranges ranges))
    (if (null ranges)
      `(progn ,@body)
      (destructuring-bind (var from below) (first ranges)
        `(loop
           :for ,var :from ,from :below ,below
           :do ,(recur (rest ranges)))))))

(defmacro do-irange (ranges &body body)
  "Perform `body` on the given inclusive `ranges`.

  Each range in `ranges` should be of the form `(variable from to)`.  During
  iteration `body` will be executed with `variable` bound to successive values
  in the range [`from`, `to`].

  If multiple ranges are given they will be iterated in a nested fashion.

  Example:

    (do-irange ((x  0  2)
                (y 10 11))
      (pr x y))
    ; =>
    ; 0 10
    ; 0 11
    ; 1 10
    ; 1 11
    ; 2 10
    ; 2 11

  "
  (assert (not (null ranges)) ()
    "Ranges to iterate in DO-RANGE must not be null.")
  (recursively ((ranges ranges))
    (if (null ranges)
      `(progn ,@body)
      (destructuring-bind (var from to) (first ranges)
        `(loop
           :for ,var :from ,from :to ,to
           :do ,(recur (rest ranges)))))))