; 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
          define-er-macro define-ir-macro)
  (import scheme chicken)

 ;;; (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 (fx< (length form) 4)
        (error 'bind "macro-form 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))))))))))))

;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-identifiers)
;;;       . 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?)
      (if (not (fx= (length f) 3))
        `(error 'define-ir-macro
                "form doesn't match pattern"
                '(_ macro-form inject-xpr))
        (let ((macro-form (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 
                                 (fx- (string-length idstring)
                                      (string-length sufstring))))))))
          (cond
            ((not (pair? macro-form))
             `(error 'define-ir-macro "not a macro form" ',macro-form))
            ((not (and (list? inject-xpr)
                       (fx= (length inject-xpr) 3)
                       (c? (car inject-xpr) 'injecting)
                       (list? (cadr inject-xpr))))
             `(error 'define-ir-macro "not an injecting expression"
                     ',inject-xpr))
            (else
              (let ((name (car macro-form))
                    (args (cdr macro-form))
                    (identifiers (cadr inject-xpr))
                    (compare-xpr (caddr inject-xpr)))
                (if (not (and (list? compare-xpr)
                              (c? (car compare-xpr) 'comparing)
                              (list? (cadr compare-xpr))))
                  `(error 'define-ir-macro "not a comparing expression"
                          ',compare-xpr)
                  (let ((predicates (cadr compare-xpr))
                        (body (cddr 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-identifiers (cdr predicates)))
                          (let ((syms (map (lambda (id) (strip-suffix suffix id))
                                           suffixed-identifiers)))
                            (if (null? identifiers)
                              `(define-syntax ,name
                                 (ir-macro-transformer
                                   (lambda (form inject compare?)
                                     (bind ,args (cdr form)
                                       (bind ,suffixed-identifiers
                                         (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-identifiers
                                           (list ,@(map (lambda (s)
                                                          `(lambda (n)
                                                             (compare? n ',(i s))))
                                                        syms))
                                           ,@body)))))))))))))))))))))

;;; (define-er-macro (name . args)
;;;   (renaming (prefix . prefixed-identifiers)
;;;     (comparing ()|(suffix . suffixed-identifiers)
;;;     . 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?)
      (if (not (fx= (length f) 3))
        `(error 'define-er-macro
                "macro-form doesn't match pattern"
                '(_ macro-form rename-xpr))
        (let ((macro-form (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 
                                 (fx- (string-length idstring)
                                      (string-length sufstring))))))))
          (cond
            ((not (pair? macro-form))
             `(error 'define-er-macro "not a macro form" ',macro-form))
            ((not (and (list? rename-xpr)
                       (fx= (length rename-xpr) 3)
                       (c? (car rename-xpr) (r 'renaming))
                       (pair? (cadr rename-xpr))))
             `(error 'define-er-macro "not a renaming expression"
                     ',rename-xpr))
            (else
              (let ((name (car macro-form))
                    (args (cdr macro-form))
                    (prefix (caadr rename-xpr))
                    (prefixed-identifiers (cdadr rename-xpr))
                    (compare-xpr (caddr rename-xpr)))
                (if (not (and (list? compare-xpr)
                              (c? (car compare-xpr) (r 'comparing))
                              (list? (cadr compare-xpr))))
                  `(error 'define-er-macro "not a comparing expression"
                          ',compare-xpr)
                  (let ((identifiers (map (lambda (id) (strip-prefix prefix id))
                                          prefixed-identifiers))
                        (predicates (cadr compare-xpr))
                        (body (cddr 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-identifiers (cdr predicates)))
                        (let ((syms (map (lambda (id) (strip-suffix suffix id))
                                         suffixed-identifiers)))
                          `(,%define-syntax ,name
                             (,%er-macro-transformer
                               (,%lambda (,%form ,%rename ,%compare?)
                                 (,%bind ,args (,%cdr ,%form)
                                   (,%bind ,prefixed-identifiers
                                           (,%map ,%rename ',identifiers)
                                     (,%bind ,suffixed-identifiers
                                       (,%list ,@(map (lambda (s)
                                                        `(lambda (n)
                                                           (,%compare? n (,%rename ',s))))
                                                      syms))
                                       ,@body)))))))))))))))))))

(define (list-bindings . args)
  (let ((lst '(bind bind-case bindable? bind/cc define-er-macro define-ir-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-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-er-macro)
         '(macro (renaming comparing)
            (_ (name . args) 
               (renaming (prefix . prefixed-identifiers)
                 (comparing ()|(suffix . suffixed-identifiers)
                   . body)))
            "Simplifies explicit-renaming macros by destructuring
            the macro-form (name . args), binding prefixed-identifiers
            to its own name but with prefix stripped and providing
            predicates to check if a symbol compares to the predicate's
            name with the suffix stripped"))
        ((define-ir-macro)
         '(macro (injecting comparing)
            (_ (name . args) 
               (injecting identifiers
                 (comparing ()|(suffix . suffixed-identifiers)
                   . body)))
            "Simplifies implicit-renaming macros by destructuring
            the macro-form (name . args), injecting the identifiers
            and providing predicates to check if a symbol compares to
            the predicate's name with its suffix stripped"))
        (else lst)))))

) ; module list-bindings

;(import list-bindings)
;(use simple-tests)  
;
;
;(pe '(define-ir-macro (ifreeze xpr)
;       (injecting ()
;         (comparing () `(lambda () ,xpr)))))
;
;(pe '(define-ir-macro (alambda args xpr . xprs)
;       (injecting (self)
;         (comparing ()
;           `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
;              ,self)))))
;
;(pe '(define-ir-macro (name . args)
;       (injecting ()
;         (comparing (? a? b?) body))))
;(pe '(define-ir-macro (name . args)
;       (injecting (x y)
;         (comparing (? a? b?) body))))
;
;(pe '(define-er-macro (name . args)
;       (renaming (% %x %y)
;         (comparing () body))))
;(pe '(define-er-macro (name . args)
;       (renaming (% %x %y)
;         (comparing (? a? b?) body))))
;(pe '(define-er-macro (foo pair)
;       (renaming (% %if)
;         (comparing (? bar?)
;           `(,%if ,(bar? (car pair)) ,@(cdr pair) 'unchecked)))))
;
;