; Copyright (c) 2022-2024 , Juergen Lorenz, ju (at) jugilo (dot) de
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
; 
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in the
; documentation and/or other materials provided with the distribution.
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission. 
;   
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


#|[
A simplified implemention of pattern matching and bindings.
Only nested sequeces of pseudo-lists are considered.
Most macros are based on bind, a version of Common Lisp's
destructuring-bind. But bind-case is enhanced with a where
clause, which makes this macro much more expressive.
]|#

(module simple-binds (
  bind
  bindable?
  set-all!
  define-all
  bind-case
  bind-let*
  bind-let
  bind-letrec
  bindrec
  simple-binds
  )

(import scheme
        (only (chicken base) error print case-lambda)
        )

#|[
(bind pat tree xpr . xprs)
--- macro ---
binds pattern variables of the pattern pat to corresponding
items in the tree and executes xpr . xprs in this context.
pat and tree needn't be flat, they can be deeply nested pseudo-lists
of symbols.
]|#
(define-syntax bind
  (syntax-rules ()
    ((_ () tree xpr . xprs)
     (apply (lambda () xpr . xprs) tree))
    ((_ (a . b) tree xpr . xprs)
     (bind a (car tree) (bind b (cdr tree) xpr . xprs)))
    ((_ a tree xpr . xprs)
     ((lambda (a) xpr . xprs) tree))
    ))

#|[
(bindable? pat tree)
--- macro ---
tests, if the items in the tree can be bound to
pattern variables in pat.
]|#
(define-syntax bindable?
  (syntax-rules ()
    ((_ () tree)
     (null? tree))
    ((_ (a . b) tree)
     (and (pair? tree)
          (bindable? a (car tree))
          (bindable? b (cdr tree))))
    ((_ a tree) #t)
    ))

#|[
(set-all! pat tree)
--- macro ---
sets pattern variables in pat to corresponding items
in tree
]|#
(define-syntax set-all!
  (syntax-rules ()
    ((_ () tree)
     (if (null? tree)
       (begin)
       (error 'set-all! "match error" '() tree))
       )
    ((_ (a . b) tree)
     (if (pair? tree)
       (begin (set-all! a (car tree))
              (set-all! b (cdr tree)))
       (error 'set-all! "match error" '(a . b) tree)))
    ((_ a tree)
     (set! a tree))
    ))

#|[
(define-all pat tree)
--- macro ---
defines pattern variables in pat by setting them
to corresponding items in tree
]|#
(define-syntax define-all
  (syntax-rules ()
    ((_ pat tree)
     ;; necessary indirection for common state argument,
     ;; cf. push, top, pop below
     (bind-let ((pat 'pat))
       (set-all! pat tree)))))

#|[
(bind-case tree (pat (where . fenders) xpr . xprs) ....)
(bind-case tree (pat xpr . xprs) ....)
--- macro ---
Checks if tree matches patterns pat  ....
in sequence, binds the pattern variables of the first matching
pattern to corresponding subexpressions of tree and executes
body expressions xpr . xprs in this context
]|#
(define-syntax bind-case
  (syntax-rules (where)
    ((_ tree)
     (error 'bind-case "no pattern to match" tree))
    ((_ tree (pat (where . fenders) xpr . xprs))
     (or (bind pat tree (and (and . fenders) xpr . xprs))
         (error 'bind-case
                "sequence doesn't match pattern with fenders"
                tree 'pat 'fenders)))
    ((_ tree (pat xpr . xprs))
     (if (bindable? pat tree)
       (bind pat tree xpr . xprs)
       (error 'bind-seq "tree doesn't match pattern" tree 'pat)))
    ((_ tree (pat (where . fenders) xpr . xprs) . clauses)
     (if (bindable? pat tree)
       (or (bind pat tree (and (and . fenders) xpr . xprs))
           (bind-case tree . clauses))))
    ((_ tree (pat xpr . xprs) . clauses)
     (if (bindable? pat tree)
       (bind pat tree xpr . xprs)
       (bind-case tree . clauses)))
    ))

#|[
(bind-let* ((pat tree) ...) xpr . xprs)
--- macro ---
sequentually binding patterns to trees
]|#
(define-syntax bind-let*
  (syntax-rules ()
    ((_ () xpr . xprs)
     (let () xpr . xprs))
    ((_ ((pat tree)) xpr . xprs)
     (bind pat tree xpr . xprs))
    ((_ ((pat tree) (pat1 tree1) ...) xpr . xprs)
     (bind pat tree (bind-let* ((pat1 tree1) ...) xpr . xprs)))
     ))

#|[
(bind-let name .. ((pat tree) ...) xpr . xprs)
(bind-let ((pat tree) ...) xpr . xprs)
--- macro ---
binding patterns to sequences in parallel, whith or without a
recursive name procedure
]|#
(define-syntax bind-let
  (syntax-rules ()
    ((_ ((pat tree) ...) xpr . xprs)
     (bind (pat ...) (list tree ...) xpr . xprs))
    ((_ name ((pat tree) ...) xpr . xprs)
     ((letrec ((name ;(bind-lambda* (pat ...) xpr . xprs)))
                     (lambda xs (bind (pat ...) xs xpr . xprs))))
        name)
      tree ...))
    ))

#|[
(bind-letrec ((pat tree) ...) xpr . xprs)
--- macro ---
binding patterns to sequences recursively
]|#
(define-syntax bind-letrec
  (syntax-rules ()
    ((_ ((pat tree) ...) xpr . xprs)
     (bind-let ((pat 'pat) ...)
       (set-all! (pat ...) (list tree ...))
       xpr . xprs))))
    
#|[
(bindrec pat tree xpr . xprs)
--- macro ---
recursive version of bind
]|#
(define-syntax bindrec
  (syntax-rules ()
    ((_ pat tree xpr . xprs)
     (bind pat 'pat
       (set-all! pat tree)
       xpr . xprs))))

#|[
(simple-binds)
(simple-binds sym)
--- procedure ---
documentation procedure
]|#
(define simple-binds
  (let (
    (alist '(
      (bind
        macro:
        (bind pat tree xpr . xprs)
        "binds pattern variables of the pattern pat to corresponding"
        "items in the tree and executes xpr . xprs in this context."
        "pat and tree needn't be flat, they can be deeply nested pseudo-lists"
        "of symbols."
        )
      (bindable?
        macro:
        (bindable? pat tree)
        "tests, if the items in the tree can be bound to"
        "pattern variables in pat."
        )
      (set-all!
        macro:
        (set-all! pat tree)
        "sets pattern variables in pat to corresponding items"
        "in tree"
        )
      (define-all
        macro:
        (define-all pat tree)
        "defines pattern variables in pat by setting them"
        "to corresponding items in tree"
        )
      (bind-case
        macro:
        (bind-case tree (pat (where . fenders) xpr . xprs) ....)
        (bind-case tree (pat xpr . xprs) ....)
        "Checks if tree matches patterns pat  ...."
        "in sequence, binds the pattern variables of the first matching"
        "pattern to corresponding subexpressions of tree and executes"
        "body expressions xpr . xprs in this context"
        )
      (bind-let*
        macro:
        (bind-let* ((pat tree) ...) xpr . xprs)
        "sequentually binding patterns to trees"
        )
      (bind-let
        macro:
        (bind-let name .. ((pat tree) ...) xpr . xprs)
        (bind-let ((pat tree) ...) xpr . xprs)
        "binding patterns to sequences in parallel, whith or without a"
        "recursive name procedure"
        )
      (bind-letrec
        macro:
        (bind-letrec ((pat tree) ...) xpr . xprs)
        "binding patterns to sequences recursively"
        )
      (bindrec
        macro:
        (bindrec pat tree xpr . xprs)
        "recursive version of bind"
        )
      (simple-binds
        procedure:
        (simple-binds)
        (simple-binds sym)
        "with sym: documentation of exported symbol"
        "without sym: list of exported symbols"
        )
        ))
      )
      (case-lambda
        (() (map car alist))
        ((sym)
         (let ((pair (assq sym alist)))
           (if pair
             (for-each print (cdr pair))
             (print "Choose one of " (map car alist))))))))
)