; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Copyright (c) 2013, Juergen Lorenz
; 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.
; 
;This module provides simplyfied versions of some of the bindings
;macros, restricting destructuring to nested list expressions, as well
;as two macros making the writing of low-level-macros easy.

(module list-bindings
  (export list-bindings bind bindable? bind-case bind/cc
          bind-let bind-let*
          define-macro let-macro letrec-macro)
  (import scheme (only chicken condition-case error))

 ;;; (bind pat list-xpr . body)
 ;;; --------------------------
 ;;; Common Lisp's destructuring bind
 ;;; binds pattern variables of pat to corresponding subexpression of
 ;;; list-xpr and evalueates body in this context
(define-syntax bind
  (ir-macro-transformer
    (lambda (form inject compare?)
      (if (< (length form) 4)
        (error 'bind "macro-code doesn't match pattern "
               '(_ pat lst xpr . xprs))
        (let ((pat (cadr form))
              (xpr (caddr form))
              (body (cdddr form)))
          (letrec (
            (pmap (lambda (pl)
                    (cond
                      ((pair? pl)
                       (cons (if (symbol? (car pl)) (car pl) (gensym)) (pmap (cdr pl))))
                      ((null? pl) pl)
                      ((symbol? pl) pl)
                      )))
            (listify (lambda (pl)
                       (cond
                         ((pair? pl)
                          (cons (car pl) (listify (cdr pl))))
                         ((null? pl) pl)
                         ((symbol? pl) (list pl)))))
            (flat? (lambda (pl)
                     (or (symbol? pl)
                         (null? pl)
                         (and (symbol? (car pl)) (flat? (cdr pl))))))
            (nested-lambda-list? (lambda (xpr)
                                   (or (symbol? xpr)
                                       (null? xpr)
                                       (and (pair? xpr)
                                            (nested-lambda-list? (car xpr))
                                            (nested-lambda-list? (cdr xpr))))))
            )
            (if (not (nested-lambda-list? pat))
              (error 'bind "not a nested lambda-list" pat)
              (if (flat? pat)
                (cond
                  ((pair? pat)
                   `(apply (lambda ,pat ,@body) ,xpr))
                  ((null? pat)
                   `(apply (lambda ,pat ,@body) ,xpr))
                  ((symbol? pat)
                   `((lambda (,pat) ,@body) ,xpr)))
                (let ((new-pat (pmap pat)))
                  (let ((lst `(bind ,new-pat ,xpr
                                (list ,@(listify new-pat)))))
                     `(bind ,(car pat) (car ,lst)
                       (bind ,(listify (cdr pat)) (cdr ,lst)
                         ,@body))))))))))))

;;; (bind-let* ((pat seq) ...) xpr . xprs)
;;; --------------------------------------
(define-syntax bind-let*
  (syntax-rules ()
    ((_ () xpr . xprs)
     (let () xpr . xprs))
    ((_ ((pat0 seq0) (pat1 seq1) ...) xpr . xprs)
     (bind pat0 seq0
       (bind-let* ((pat1 seq1) ...) xpr . xprs)))))

;;; (bind-let ((pat seq) ...) xpr . xprs)
;;; -------------------------------------
(define-syntax bind-let
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((binds (cadr form))
            (xpr (caddr form))
            (xprs (cdddr form)))
        (let ((syms (map (lambda (x) (gensym)) binds)))
          `(bind ,syms ,(cons 'list (map cadr binds))
             (bind-let* ,(map (lambda (p s) `(,p ,s))
                              (map car binds)
                              syms)
               ,xpr ,@xprs)))))))

;The following macro returns a precedure, which checks, if its list
;argument matches against any of the macro's pattern arguments, and is
;hence bindable to one of the patterns.
;Examples:
;((bindable? (a b) (a)) '(1 2)) -> #t 
;((bindable? (a (b . c)) (a (b (c)))) '(1 (2 3 4)) -> #t 
;((bindable? (a (b c))) '(1 (2 3 4)) -> #f 
;
;;; (bindable? pat . pats)
;;; ------------------
(define-syntax bindable?
  (syntax-rules ()
    ((_) (lambda (x) (null? x)))
    ((_ pat)
     (lambda (x)
       (condition-case
         (bind pat x #t)
         ((exn) #f))))
    ((_ pat . pats)
     (lambda (x)
       (or ((bindable? pat) x)
           ((bindable? . pats) x))))))

;;; (bind-case list-xpr (pat xpr . xprs) ....)
;;; -------------------------------------
;;; Checks if list-xpr matches pattern pat in sequence, binds the pattern
;;; variables of the first matching pattern to corresponding sublists of
;;; list-xpr and executes corresponding body xpr . xprs
(define-syntax bind-case
  (syntax-rules ()
    ((_ list-xpr (pat  xpr . xprs))
     (bind pat list-xpr  xpr . xprs))
    ((_ list-xpr clause . clauses)
     (condition-case
       (bind-case list-xpr clause)
       ((exn)
        (bind-case list-xpr . clauses))))))

;;; (bind/cc k xpr . xprs)
;;; ----------------------
(define-syntax bind/cc
  (syntax-rules ()
    ((_ k xpr . xprs)
     (call-with-current-continuation
       (lambda (k) xpr . xprs)))))

;;; (define-ir-macro (name . args)
;;;   (injecting (identifier ...)
;;;     (comparing ()|(suffix . suffixed-keywords)
;;;       . body)))
;;; -------------------------------------------------
;;; where transformer is a unary procedure accepting
;;; ir-macro-transformer' s last parameter, compare?
(define-syntax define-ir-macro
  (ir-macro-transformer
    (lambda (f i c?)
      (let ((macro-code (cadr f))
            (inject-xpr (caddr f))
            (strip-suffix
              (lambda (suf id)
                (let ((sufstring (symbol->string suf))
                      (idstring (symbol->string id)))
                  (string->symbol
                    (substring idstring
                               0 
                               (- (string-length idstring)
                                  (string-length sufstring))))))))
        (let ((name (car macro-code))
              (args (cdr macro-code))
              (identifiers (cadr inject-xpr))
              (compare-xpr (caddr inject-xpr)))
          (let ((predicates (cadr compare-xpr))
                (body (caddr compare-xpr)))
            (cond
              ((and (null? identifiers) (null? predicates))
               `(define-syntax ,name
                  (ir-macro-transformer
                    (lambda (form inject compare?)
                      (bind ,args (cdr form)
                        ,body)))))
              ((null? predicates)
               `(define-syntax ,name
                  (ir-macro-transformer
                    (lambda (form inject compare?)
                      (bind ,args (cdr form)
                        (bind ,identifiers (map inject ',identifiers)
                          ,body))))))
              (else
                (let ((suffix (car predicates))
                      (suffixed-keywords (cdr predicates)))
                  (let ((syms (map (lambda (id) (strip-suffix suffix id))
                                   suffixed-keywords)))
                    (if (null? identifiers)
                      `(define-syntax ,name
                         (ir-macro-transformer
                           (lambda (form inject compare?)
                             (bind ,args (cdr form)
                               (bind ,suffixed-keywords
                                 (list ,@(map (lambda (s)
                                                `(lambda (n)
                                                   (compare? n ',(i s))))
                                              syms))
                                 ,body)))))
                      `(define-syntax ,name
                         (ir-macro-transformer
                           (lambda (form inject compare?)
                             (bind ,args (cdr form)
                               (bind ,identifiers (map inject ',identifiers)
                                 (bind ,suffixed-keywords
                                   (list ,@(map (lambda (s)
                                                  `(lambda (n)
                                                     (compare? n ',(i s))))
                                                syms))
                                   ,body)))))))))))))))))

;;; (define-er-macro (name . args)
;;;   (renaming (prefix . prefixed-identifiers)
;;;     (comparing ()|(suffix . suffixed-keywords)
;;;     . body)))
;;; -------------------------------------------------
;;; where transformer is a unary procedure accepting
;;; er-macro-transformer' s last parameter, compare?
(define-syntax define-er-macro
  (er-macro-transformer
    (lambda (f r c?)
      (let ((macro-code (cadr f))
            (rename-xpr (caddr f))
            (strip-prefix (lambda (pre id)
                            (string->symbol
                              (substring (symbol->string id)
                                         (string-length
                                           (symbol->string pre))))))
            (strip-suffix
              (lambda (suf id)
                (let ((sufstring (symbol->string suf))
                      (idstring (symbol->string id)))
                  (string->symbol
                    (substring idstring
                               0 
                               (- (string-length idstring)
                                  (string-length sufstring))))))))
        (let ((name (car macro-code))
              (args (cdr macro-code))
              (prefix (caadr rename-xpr))
              (prefixed-identifiers (cdadr rename-xpr))
              (compare-xpr (caddr rename-xpr)))
          (let ((identifiers (map (lambda (id) (strip-prefix prefix id))
                                  prefixed-identifiers))
                (predicates (cadr compare-xpr))
                (body (caddr compare-xpr))
                (%er-macro-transformer (r 'er-macro-transformer))
                (%define-syntax (r 'define-syntax))
                (%compare? (r 'compare?))
                (%rename (r 'rename))
                (%lambda (r 'lambda))
                (%bind (r 'bind))
                (%list (r 'list))
                (%form (r 'form))
                (%cdr (r 'cdr))
                (%map (r 'map)))
            (if (null? predicates)
              `(,%define-syntax ,name
                  (,%er-macro-transformer
                    (,%lambda (,%form ,%rename ,%compare?)
                      (,%bind ,args (,%cdr ,%form)
                              (,%bind ,prefixed-identifiers
                                      (,%map ,%rename ',identifiers)
                                ,body)))))
              (let ((suffix (car predicates))
                    (suffixed-keywords (cdr predicates)))
                (let ((syms (map (lambda (id) (strip-suffix suffix id))
                                 suffixed-keywords)))
                  `(,%define-syntax ,name
                      (,%er-macro-transformer
                        (,%lambda (,%form ,%rename ,%compare?)
                          (,%bind ,args (,%cdr ,%form)
                            (,%bind ,prefixed-identifiers
                                    (,%map ,%rename ',identifiers)
                              (,%bind ,suffixed-keywords
                                      (,%list ,@(map (lambda (s)
                                                       `(lambda (n)
                                                          (,%compare? n (,%rename ',s))))
                                                     syms))
                                      ,body)))))))))))))))

(define-syntax define-macro
  (ir-macro-transformer 
    (lambda (form inject compare?)
      (if (not (= (length form) 3))
        (error 'define-macro "macro-code doesn't match pattern"
               '(_ macro-code body))
        (let ((macro-code (cadr form)) (body (caddr form)))
          ;; create standard body
          (let ((body (if (and (list? body)
                               (= (length body) 3)
                               (list? (cadr body)))
                        (cond
                          ((compare? (car body) 'comparing)
                           `(injecting () ,body))
                          ((compare? (car body) 'injecting)
                           (let ((rest (caddr body)))
                             (if (and (list? rest)
                                      (= (length rest) 3)
                                      (list? (cadr rest))
                                      (compare? (car rest) 'comparing))
                               body
                               `(injecting ,(cadr body)
                                  (comparing () ,(caddr body))))))
                          ((compare? (car body) 'renaming)
                           (let ((rest (caddr body)))
                             (if (and (list? rest)
                                      (= (length rest) 3)
                                      (list? (cadr rest))
                                      (compare? (car rest) 'comparing))
                               body
                               `(renaming ,(cadr body)
                                 (comparing () ,(caddr body))))))
                          (else
                            (error 'define-macro "not a macro body" body)))
                        `(injecting ()
                          (comparing () ,body)))))
            (if (compare? (car body) 'injecting)
              `(define-ir-macro ,macro-code ,body)
              `(define-er-macro ,macro-code ,body))))))))

(define-syntax letrec-macro
  (er-macro-transformer
    (lambda (f r c?)
      (let ((binds (cadr f))
            (body (cddr f))
            (%letrec-syntax (r 'letrec-syntax)))
        `(,%letrec-syntax
           ,(map (lambda (m)
                   `(,(cadr m) ,(caddr m)))
                 (map (lambda (b)
                        (expand `(define-macro ,@b)))
                      binds))
           ,@body)))))

(define-syntax let-macro
  (er-macro-transformer
    (lambda (f r c?)
      (let ((binds (cadr f))
            (body (cddr f))
            (%let-syntax (r 'let-syntax)))
        `(,%let-syntax
           ,(map (lambda (m)
                   `(,(cadr m) ,(caddr m)))
                 (map (lambda (b)
                        (expand `(define-macro ,@b)))
                      binds))
           ,@body)))))

(define (list-bindings . args)
  (let ((lst '(bind bind-let* bind-let bind-case bindable? bind/cc
                define-macro let-macro letrec-macro)))
    (if (null? args)
      lst
      (case (car args)
        ((bind)
         '(macro ()
            (_ pat xpr . body)
            "binds pattern variables of pat, a nested lambda-list, to corresponding subexpressions of xpr, a nested list expression, and executes body in this scope"))
        ((bind-let*)
         '(macro ()
            (_ ((pat xpr) ...) . body)
            "binds pattern variables of pat to corresponding subexpressions of xpr ... in sequence and executes body in this context"))
        ((bind-let)
         '(macro ()
            (_ ((pat xpr) ...) . body)
            "binds pattern variables of pat to corresponding subexpressions of xpr ... in parallel and executes body in this context"))
        ((bind-case)
         '(macro ()
            (_ xpr (pat0 . body0) (pat1 . body1) ...)
            "tries to bind subexpressions of xpr to pat0 pat1 ...  in sequence and executes the corresponding body in the matching scope"))
        ((bindable?)
         '(macro ()
            (_ pat0 pat1 ...)
            "returns a predicate,which checks, if its only list argument matches any of the patterns pat0 pat1 ..."))
        ((bind/cc)
         '(macro ()
            (_ cont . body)
            "captures current continuation, binds it to cont and executes body in this scope"))
        ((define-macro)
         '(macro (injecting renaming comparing)
            (_ (name . args) body)
            "where body is either a renaming expression of the form (renaming (prefix . prefixed-identifiers) comparing-expression), an injecting expression of the form (injecting identifiers comparing-expression) or any other expression. A comparing expression is of the form (comparing predicates xpr) where predicates is either null or of the form (suffixed .  suffixed-keywords). defines macro name by destructuring the macro-code (name .  args) and binding identifiers or prefixed-identifiers with injected or renamed and prefix-stripped versions of itself as well as binding suffixed-keywords to predicates comparing its only argument to suffix-stripped versions of itself.  Evaluates xpr in this context or body if body is neither an injecting nor a renaming expression."))
        ((let-macro)
         '(macro ()
            (_ ((macro-code macro-body) ...) . body)
            "creates macros with macro-code and macro-body ... in parallel and evaluates body in this context"))
        ((letrec-macro)
         '(macro ()
            (_ ((macro-code macro-body) ...) . body)
            "creates macros with macro-code and macro-body ... recursively and evaluates body in this context"))
        (else lst)))))

) ; module list-bindings