;;; Arl Standard Library - Binding Macros

(module binding
  (export pattern-symbols destructuring-bind let let* letrec when-let if-let)

  (import types :refer (symbol? list-or-pair? null?))
  (import list :refer (append))
  (import sequences :refer (zip))

;;' @section Binding Macros

;;' @description Collect all symbols from a destructuring pattern, ignoring dots.
;;' @signature (pattern-symbols pattern)
;;' @param pattern Nested list/symbol pattern to extract symbol names from
;;' @seealso destructuring-bind
(define pattern-symbols
  (lambda (pattern)
    (if (symbol? pattern)
      (if (= (as.character pattern) ".")
        (list)
        (list pattern))
      (if (list-or-pair? pattern)
        (begin
          (define head (car pattern))
          (define tail (cdr pattern))
          (if (and (symbol? head) (= (as.character head) "."))
            (if (null? tail) (list) (pattern-symbols (car tail)))
            (append (pattern-symbols head) (pattern-symbols tail))))
        (list)))))

;;' @description Bind a destructuring pattern to a value, then evaluate body forms.
;;' @param pattern Destructuring pattern (possibly nested, with . for rest)
;;' @param value Expression whose result is destructured
;;' @param body Expressions evaluated with the pattern bindings in scope
;;' @examples
;;' (destructuring-bind (a b c) (list 1 2 3)
;;'   (+ a b c))                 ; => 6
;;' (destructuring-bind (x . rest) (list 10 20 30)
;;'   rest)                      ; => (20 30)
;;' @assert
;;' (assert-equal 6 (destructuring-bind (a b c) (list 1 2 3) (+ a b c)))
;;' (assert-equal (list 20 30) (destructuring-bind (x . rest) (list 10 20 30) rest))
;;' @seealso let, let*, pattern-symbols
(defmacro destructuring-bind (pattern value . body)
  (define tmp (gensym "tmp"))
  `((lambda (,tmp)
      (define ,pattern ,tmp)
      (begin ,@body))
    ,value))

;;' @description Bind names to values within body.
;;' @param bindings List of (pattern value) pairs, evaluated in parallel
;;' @param body Expressions evaluated with the bindings in scope
;;' @examples
;;' (let ((x 1) (y 2))
;;'   (+ x y))               ; => 3
;;'
;;' (let ((x 10))
;;'   (* x x))               ; => 100
;;' @assert
;;' (assert-equal 3 (let ((x 1) (y 2)) (+ x y)))
;;' (assert-equal 100 (let ((x 10)) (* x x)))
;;' @note Bindings are evaluated in parallel: earlier bindings are NOT visible to later ones. Use `let*` for sequential binding.
;;' @seealso let*, letrec
(defmacro let (bindings . body)
  (if (null? bindings)
    `(begin ,@body)
    (begin
      (define temps (lapply bindings (lambda (b) (gensym "tmp"))))
      (define patterns (lapply bindings car))
      (define values (lapply bindings (lambda (b) (car (cdr b)))))
      `((lambda ,temps
          ,@(lapply (zip patterns temps)
                    (lambda (pair)
                      `(define ,(car pair) ,(car (cdr pair)))))
          (begin ,@body))
        ,@values))))

;;' @description Sequential let bindings.
;;' @param bindings List of (pattern value) pairs, evaluated sequentially
;;' @param body Expressions evaluated with the bindings in scope
;;' @examples
;;' (let* ((x 1) (y (+ x 1)))
;;'   (+ x y))               ; => 3
;;'
;;' (let* ((a 10) (b (* a 2)) (c (+ a b)))
;;'   c)                      ; => 30
;;' @assert
;;' (assert-equal 3 (let* ((x 1) (y (+ x 1))) (+ x y)))
;;' (assert-equal 30 (let* ((a 10) (b (* a 2)) (c (+ a b))) c))
;;' @note Bindings are evaluated sequentially: each binding can refer to previously bound names. Supports destructuring patterns.
;;' @seealso let, letrec
(defmacro let* (bindings . body)
  (if (null? bindings)
    `(begin ,@body)
    (begin
      (define binding (car bindings))
      (define pattern (car binding))
      (define value (car (cdr binding)))
      `(destructuring-bind ,pattern ,value
         (let* ,(cdr bindings) ,@body)))))

;;' @description Recursive bindings.
;;' @param bindings List of (name value) pairs, all mutually visible
;;' @param body Expressions evaluated with the bindings in scope
;;' @examples
;;' (letrec ((even? (lambda (n) (if (= n 0) #t (odd? (- n 1)))))
;;'          (odd?  (lambda (n) (if (= n 0) #f (even? (- n 1))))))
;;'   (even? 10))             ; => #t
;;' @assert
;;' (assert-true (letrec ((ev? (lambda (n) (if (= n 0) #t (od? (- n 1))))) (od? (lambda (n) (if (= n 0) #f (ev? (- n 1)))))) (ev? 10)))
;;' @note All bindings are visible to all init expressions, enabling mutual recursion. Init values are assigned via `set!` into pre-allocated slots.
;;' @seealso let, let*
(defmacro letrec (bindings . body)
  (define names (do.call c (lapply bindings (lambda (b) (pattern-symbols (car b))))))
  `(let ,(lapply names (lambda (n) `(,n (list))))
     ,@(lapply bindings (lambda (b) `(set! ,(car b) ,(car (cdr b)))))
     (begin ,@body)))

;;' @description Bind pattern to value and evaluate body when value is truthy.
;;' @param binding Single (pattern value) pair
;;' @param body Expressions evaluated when value is truthy, with pattern bound
;;' @examples
;;' (when-let (x (assoc 'a (list (list 'a 1) (list 'b 2))))
;;'   (cadr x))              ; => 1
;;'
;;' (when-let (x #f)
;;'   "never reached")       ; => #nil
;;' @assert
;;' (assert-equal 1 (when-let (x (assoc 'a (list (list 'a 1) (list 'b 2)))) (cadr x)))
;;' (assert-equal #nil (when-let (x #f) "never reached"))
;;' @seealso if-let, when, let
(defmacro when-let (binding . body)
  (begin
    (define pattern (car binding))
    (define value (car (cdr binding)))
    (define tmp (gensym "when-let"))
    `((lambda (,tmp)
        (if (car ,tmp)
          (destructuring-bind ,pattern (car ,tmp)
            (begin ,@body))
          #nil))
      (list ,value))))

;;' @description Bind pattern to value and choose branch based on its truthiness.
;;' @param binding Single (pattern value) pair
;;' @param then Expression evaluated when value is truthy, with pattern bound
;;' @param rest Optional else expression when value is falsy
;;' @examples
;;' (if-let (x 42)
;;'   (+ x 1)
;;'   "nothing")             ; => 43
;;'
;;' (if-let (x #f)
;;'   "truthy"
;;'   "falsy")               ; => "falsy"
;;' @assert
;;' (assert-equal 43 (if-let (x 42) (+ x 1) "nothing"))
;;' (assert-equal "falsy" (if-let (x #f) "truthy" "falsy"))
;;' @seealso when-let, if, let
(defmacro if-let (binding then . rest)
  (begin
    (define pattern (car binding))
    (define value (car (cdr binding)))
    (define else (if (null? rest) #nil (car rest)))
    (define tmp (gensym "if-let"))
    `((lambda (,tmp)
        (if (car ,tmp)
          (destructuring-bind ,pattern (car ,tmp)
            ,then)
          ,else))
      (list ,value))))
)
