; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
;
; Copyright (c) 2013-2014, 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 dispasser.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following dispasser 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.

(require-library lolevel)

(module multi-methods
  (export multi-methods
          (define-multi-method list->tree mm-search mm-insert!)
          multi-method-insert!
          (pass %pass)
          (pass* %pass*)
          tag nlambda get-tag tagged-procedure?
          multi-method? multi-method-variadic?
          multi-method-empty? multi-method-arity
          multi-method-keys multi-method-tree)

(import scheme
        (only chicken condition-case case-lambda receive assert gensym error fx<)
        (only extras format)
        (only data-structures list-of?)
        (only lolevel extend-procedure procedure-data extended-procedure?))

;;; (multi-methods [sym])
;;; ---------------------
;;; documentation procedure
(define multi-methods
  (let ((signatures
          '((define-multi-method (name . args))
            (multi-method-insert! multi proc* . keys)
            (multi-method? xpr)
            (multi-method-empty? xpr)
            (multi-method-variadic? xpr)
            (multi-method-arity multi)
            (multi-method-keys multi . keys)
            (multi-method-tree multi . keys)
            (pass ok? . oks?)
            (pass* ok? . oks?)
            (nlambda name args xpr . xprs)
            (tag proc [sym])
            (get-tag nproc)
            (tagged-procedure? xpr))))
    (case-lambda
      (() (map car signatures))
      ((sym) (assq sym signatures)))))

;;; (define-multi-method (name . args))
;;; -----------------------------------
;;; defines an empty multi-method with signature (name . args)
(define-syntax define-multi-method
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let (;(signature (cadr form))
            (name (caadr form))
            (vars (cdadr form))
            (listify (lambda (pair)
                       (cond
                         ((list? pair) pair)
                         ((pair? pair)
                          (let loop ((pair pair))
                            (if (not (pair? (cdr pair)))
                              (cons (car pair) (list (cdr pair)))
                              (cons (car pair) (listify (cdr pair))))))
                         (else (list pair))))))
        `(define ,name
           (let ((proc-tree '())
                 (type (gensym 'multi-method))
                 (arity ,(length (listify vars)))
                 (variadic? ,(not (list? vars))))
             (case-lambda
               (()
                (values
                  (lambda (sym)
                    ;; access state information
                    (case sym
                      ((proc-tree) proc-tree)
                      ((arity) arity)
                      ((variadic?) variadic?)
                      ((type) type)
                      ((insert!)
                       (lambda (proc-list . keys)
                         (set! proc-tree
                               (apply mm-insert!
                                      proc-tree
                                      (list->tree proc-list)
                                      keys))))
                      (else (error 'multi-method
                                   "message not understood"
                                   sym))))
                  type))
               (,vars
                 ;; find matching procedure and apply it
                 (let ((found (mm-search proc-tree ,@(listify vars))))
                   (cond
                     ((and found variadic?)
                      (apply found ,@(listify vars)))
                     (found
                       (found ,@(listify vars)))
                     (else
                       (error ',name
                              (format #f "no routine matches ~s~%"
                                      (list ,@(listify vars))))))))
               (args
                 (error ',name
                        (format #f "~s doesn't match ~s"
                                args ',vars))))))))))

;; helper
(define-syntax dissect
  (syntax-rules (:)
    ;; variadic
    ((_ (name ((a a? a1? ...) (b b? b1? ...)
               ... : (cs cs? cs1? ...))
              xpr . xprs))
     (list (nlambda name (a b ... . cs) xpr . xprs)
           (pass a? a1? ...)
           (pass b? b1? ...)
           ...
           (pass* cs? cs1? ...)))
    ;; not variadic
    ((_ (name ((a a? a1? ...) (b b? b1? ...) ...)
              xpr . xprs))
     (list (nlambda name (a b ...) xpr . xprs)
           (pass a? a1? ...)
           (pass b? b1? ...)
           ...))
    ;; variadic
    ((_ (name (as as? as1? ...) xpr . xprs))
     (list (nlambda name as xpr . xprs)
           (pass* as? as1? ...)))
    ))

;;; (multi-method-insert! multi
;;;                       (name ((arg arg? ...) ...) xpr . xprs)
;;;                       . keys)
;;; ------------------------------------------------------------
;;; inserts the name routine into multi's state at the proper place
;;; defined by keys 
(define-syntax multi-method-insert!
  (syntax-rules ()
    ((_ multi proc . keys)
     (((multi) 'insert!)
      (dissect proc)
      . keys))))

;;; (nlambda name args xpr . xprs)
;;; ------------------------------
;;; returns a possibly recursive procedure tagged with 'name.
(define-syntax nlambda
  (syntax-rules ()
    ((_ name args xpr . xprs)
     (letrec ((name (lambda args xpr . xprs)))
       (tag name 'name)))))

;;; (tag proc [sym])
;;; ----------------
;;; tags a procedure proc with a symbol, if provided, or with itself
;;; quoted.
(define-syntax tag
  (syntax-rules ()
    ((_ proc sym)
     (extend-procedure proc sym))
    ((_ proc)
     (tag proc 'proc))))

;;; (pass ok? ok1? ...)
;;; -------------------
;;; processes a fixed argument.
;;; Returns a tagged procedure which checks, if its only fixed
;;; argument is accepted by each of the predicates ok? ok1? ...
;;; If so, returns the fixed argument, if not returns the failing
;;; predicate.
(define-syntax pass
  (ir-macro-transformer
    (lambda (form inject compare?)
      `(%pass
         ,@(map (lambda (p)
                  `(if (tagged-procedure? ,p)
                     ,p
                     (tag ,p)))
                (cdr form))))))
;;; internal to pass
(define (%pass . oks?)
  (assert ((list-of? tagged-procedure?) oks?))
  (tag
    (lambda (arg)
      ;; should return either arg or the failing tagged predicate
      (cond
        ((null? oks?)
         arg)
        (((car oks?) arg)
         ((apply %pass (cdr oks?)) arg))
        (else (car oks?)))) ;;;
    (string->symbol
      (apply string-append
             (map (lambda (o)
                    (symbol->string
                      (get-tag o)))
                  oks?)))))


;;; (pass* ok? ok1? ...)
;;; --------------------
;;; processes the last variadic argument as a list.
;;; Returns a tagged procedure which checks, if its only variadic
;;; argument is accepted by each of the predicates list-of-  ok? ok1? ...
;;; If so, returns the variadic argument, if not returns the failing
;;; predicate.
;;; Note that the variadic argument mustn't be empty,
;;; otherwise there is nothing to dispatch on
(define-syntax pass*
  (ir-macro-transformer
    (lambda (form inject compare?)
      `(%pass*
         ,@(map (lambda (p)
                  `(if (tagged-procedure? ,p)
                     ,p
                     (tag ,p)))
                (cdr form))))))
;;; internal to pass*
(define (%pass* . oks?)
  (assert ((list-of? tagged-procedure?) oks?))
  (tag
    (lambda (args)
      ;; should return either args or a failing tagged predicate
      (if (null? args)
        (nlambda wrong? (x) #f) ;;;
        (cond
          ((null? oks?)
           args)
          (((list-of? (car oks?)) args)
           ((apply %pass* (cdr oks?)) args))
          (else (car oks?))))) ;;;
    (string->symbol
      (apply string-append
             (map (lambda (o)
                    (string-append "list-of-"
                                   (symbol->string
                                     (get-tag o))))
                  oks?)))))


;;; (tagged-procedure? xpr)
;;; -----------------------
;;; evaluates xpr to a tagged procedure?
(define (tagged-procedure? xpr)
  (and (extended-procedure? xpr)
       (symbol? (procedure-data xpr))))

;;; (get-tag proc)
;;; --------------
;;; returns the tag of a tagged-procedure proc
(define (get-tag proc)
  (assert (tagged-procedure? proc))
  (procedure-data proc))

;;; (multi-method? xpr)
;;; -------------------
;;; type predicate for multi-methods
(define (multi-method? xpr)
  (and (procedure? xpr)
       (condition-case
         (receive (proc type) (xpr)
           (eq? (proc 'type) type))
         ((exn) #f))))

;;; (multi-method-empty? multi)
;;; ---------------------------
;;; checks, if multi is an empty multi-method
(define (multi-method-empty? multi)
  (and (multi-method? multi)
       (null? ((multi) 'proc-tree))))

;;; (multi-method-variadic? multi)
;;; ------------------------------
;;; checks, if multi is a variadic multi-method
(define (multi-method-variadic? multi)
  (and (multi-method? multi)
       ((multi) 'variadic?)))

;;; (multi-method-arity multi)
;;; --------------------------
;;; returns the arity of a multi-method
(define (multi-method-arity multi)
  (assert (multi-method? multi))
  ((multi) 'arity))

;;; (multi-method-keys multi . keys)
;;; --------------------------------
;;; inspects the multi-method multi vertically
(define (multi-method-keys multi . keys)
  (assert (multi-method? multi))
  (assert ((list-of? symbol?) keys))
  (assert (fx< (length keys) ((multi) 'arity)))
  (letrec ((tree-memq (lambda (sym tree)
                        (let loop ((tree tree))
                          (cond
                            ((null? tree)
                             '())
                            ((procedure? (cadar tree))
                             tree)
                            ((eq? sym (get-tag ;tree))
                                                      (caar tree)))
                             tree)
                            (else (cdr tree))))))
           (tree-ref (lambda (tree . syms)
                       (cond
                         ((null? syms)
                          tree)
                         ((null? (cdr syms))
                          (cadar (tree-memq (car syms) tree)))
                         (else
                           (apply tree-ref
                                  (cadar (tree-memq (car syms) tree))
                                  (cdr syms)))))))
    (let loop ((proc-tree ((multi) 'proc-tree))
               (keys keys))
      (if (null? keys)
        (map get-tag (map car proc-tree))
        (let ((mpt (tree-ref proc-tree (car keys))))
          (loop mpt (cdr keys)))))))

;;; (multi-method-tree multi . keys)
;;; --------------------------------
;;; inspects the multi-method multi horizontally
(define (multi-method-tree multi . keys)
  (assert (multi-method? multi))
  (assert ((list-of? symbol?) keys))
  (let loop ((keys keys)
             (result (map* get-tag ((multi) 'proc-tree))))
    (if (null? keys)
      result
      (loop (cdr keys)
            (condition-case (cadr (assq (car keys) result))
              ((exn) #f))))))

;;;;;;; internal procedures ;;;;;
;;;;;;; ------------------- ;;;;;

(define (assp ok? alist)
  (let loop ((al alist))
    (cond
      ((null? al) #f) ; error ?
      ((ok? (caar al))
       (cadar al))
      (else
        (loop (cdr al))))))

(define (search mmtree arg)
  (assp (lambda (ok?)
           ;; note that if ok? is a %pass expression,
           ;; then (ok? arg) returns either arg or one of the predicates
           ;; of pass% namely the one, which fails on arg
           (condition-case ((ok? arg) arg)
             ((exn) #t)))
           ;; alternatively
           ;(equal? (ok? arg) arg))
           ;problematic because of equal?
         mmtree))

(define (mm-search mmtree . args)
  (if (null? (cdr args))
    (search mmtree (car args))
    (apply mm-search (search mmtree (car args)) (cdr args))))

(define (list->tree pair)
  (let loop ((rest (cdr pair)))
    (if (null? (cdr rest))
      (list (list (car rest) (car pair)))
      (list (cons (car rest)
                  (list (loop (cdr rest))))))))

(define (map* fn tree)
  (let loop ((tree tree))
    (cond
      ((null? tree) '())
      ((pair? tree)
       (cons (loop (car tree)) (loop (cdr tree))))
      (else (fn tree)))))

(define (mm-insert! multi-tree single-tree . syms)
  (let ((splitp (lambda (ok? lst)
                  (let loop ((tail lst) (head '()))
                    (if (or (null? tail) (ok? (car tail)))
                      (values tail head)
                      (loop (cdr tail) (cons (car tail) head))))))
        (reverse* (lambda (head tail)
                    (let loop ((head head) (tail tail))
                      (if (null? head)
                        tail
                        (loop (cdr head) (cons (car head) tail)))))))
    (cond
      ((null? multi-tree)
       single-tree)
      ((null? syms)
       ;; insert at end: (gensym 'end) is never found
       (mm-insert! multi-tree single-tree (gensym 'end)))
      (else
        (let ((sym (car syms)) (rest-syms (cdr syms)))
          (receive (tail head) (splitp (lambda (x)
                                         (eq? (get-tag (car x)) sym))
                                       multi-tree)
            (cond
              ((null? tail)
               (reverse* head single-tree))
              ((and (eq? sym (get-tag (caar tail)))
                    (eq? sym (get-tag (caar single-tree))))
               (reverse* head
                         (append (list (list (caar tail)
                                             (apply mm-insert!
                                                    (cadar tail)
                                                    (cadar single-tree)
                                                    rest-syms)))
                                 (cdr tail))))
              (else
                (reverse* head (cons (car single-tree) tail))))))))))

) ; multi-methods