; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
;
; Last update: June 26, 2013
;
; 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 supplies a simplified version of generic functions, called
;multi-methods, as well as methods.

;Both methods and multi-methods are procedures with state, i.e.
;closures. They are invoked like ordinary procedures, but that results
;in checking the arguments against predicates in the respective states
;and invoking the matching procedure, stored in the state as well.
;The state of a method consists of a list of procedures, the state of a
;multi-method of a tree of procedures, which makes searching of the
;multi-methods action comparatively fast.
;
;Contrary to other implementations of generic functions, the state is
;accessible by the client. Hence the client has control over the place,
;where a method is to be inserted. This way there is no need to supply
;type hierarchies: Since more specific procedures are to be inserted
;before less specific ones, the former are found first.
;
;Since trees of procedures are not really readable by humans, all of
;them are tagged by name symbols, using the lolevel extend-procedure
;routine.
;
;These symbols are compared against optional keys in the
;multi-method-insert!  routine. No key means: insert at the end, and a
;key matching a symbol in the top level of tree: insert before the key,
;if that key doesn't also match the symbol of the method to be inserted,
;otherwise step down in the tree and recur.
;
;Note, that methods can be used for two purposes: First they can be
;inserted into a multi-method at the proper place, second they can be
;called directly providing some sort of design by contract. This is
;because preconditions are automatically checked and postconditions can
;be checked by using the car of the proc-list, a wrapper around the
;actual procedure to be applied.  This wrapper is one of the effect
;checkers which accepts a procedure as argument and returns that very
;procedure after having its effects checked.But since postcondition
;checks might be expensive, the application of it can be controlled by
;the parameter effects-checked?

(require-library lolevel data-structures)

(module method-helper (state)
(import (only scheme define quote) (only chicken gensym))
(define state (gensym 'state))
) ; module method-helper

(module methods
  (methods no-checker query-checker command-checker
           (method method-check-args-and-call)
           method-variadic?  method-arity method-name method-assumptions
           method-effects effects-checked? method?)

(import scheme
        method-helper
        (only chicken receive nth-value condition-case
              void gensym make-parameter conjoin error)
        (only data-structures chop sort)
        (only extras format)
        (only lolevel extend-procedure procedure-data))
(import-for-syntax (only chicken receive))

;;; (effects-checked? [x])
;;; ----------------------
;;; boolean parameter controlling, if postconditions are checked or not
(define effects-checked?
  (make-parameter #f
                  (lambda (x)
                   (if (boolean? x) x #f))))

;;; (method [variadic?] (proc-name proc checker) (arg-name pred . preds) ...)
;;; -------------------------------------------------------------------------
;;; method datatye constructor.
;;; proc is the actual procedure which is ultimately called,
;;; checker a procedure which accepts either proc or a special
;;; symbol as argument and returns that very proc after having checked
;;; its return values or side-effects, or returns documentation. Usually
;;; checker is one of no-checker, query-checker or command-checker.
;;; arg-name is a symbol describing the predicate (conjoin pred . preds)
;;; which does the argument check.
(define-syntax method
  (syntax-rules ()
    ((_ (proc-name proc checker) arg-clause ...)
     (method #f (proc-name proc checker) arg-clause ...))
    ((_ var? (proc-name proc checker) arg-clause ...)
     (let ((proc-list
             (list
               (extend-procedure (checker proc) proc-name)
               (extend-procedure (apply conjoin (cdr (list . arg-clause)))
                                 (car (list . arg-clause)))
               ...)))
       (lambda  args
         (if (and (not (null? args))
                  (null? (cdr args))
                  (eq? (car args) state))
           (lambda (sym)
             (case sym
               ((proc-list) proc-list)
               ((effects) (checker state))
               ((arity) (length (cdr proc-list)))
               ((variadic?) var?)
               ((name) proc-name)
               ((type) 'method)
               (else (error proc-name
                            "message not understood"
                            sym))))
           (apply method-check-args-and-call proc-list var? args)))))))
;  (ir-macro-transformer
;    (lambda (form inject compare?)
;      (let (
;        (variadic? (if (boolean? (cadr form)) (cadr form) #f))
;        (head (if (boolean? (cadr form)) (caddr form) (cadr form)))
;        (tail (if (boolean? (cadr form)) (cdddr form) (cddr form)))
;        )
;        (let (
;          (proc-name (car head))
;          (proc (cadr head))
;          (checker (caddr head))
;          (names (map car tail))
;          (preds (map cdr tail))
;          )
;          `(let ((proc-list
;                   (list
;                     (extend-procedure (,checker ,proc) ,proc-name)
;                     ,@(map (lambda (ps n)
;                              `(extend-procedure (conjoin ,@ps) ,n))
;                            preds names))))
;             (lambda  args
;               (if (and (not (null? args))
;                        (null? (cdr args))
;                        (eq? (car args) state))
;                 (lambda (sym)
;                   (case sym
;                     ((proc-list) proc-list)
;                     ((effects) (,checker state))
;                     ((arity) (length (cdr proc-list)))
;                     ((variadic?) ,variadic?)
;                     ((name) ,proc-name)
;                     ((type) 'method)
;                     (else (error ,proc-name
;                                  "message not understood"
;                                  sym))))
;                 (apply method-check-args-and-call proc-list ,variadic? args)))))))))

;;; only exported with method
(define method-check-args-and-call
  (lambda (proc-list variadic? . args)
    (let ((proc (car proc-list))
          (preds (cdr proc-list))
          (split (lambda (lst n)
                   (let loop ((tail lst) (head '()) (n n))
                     (if (or (null? tail) (zero? n))
                       (values tail (reverse head))
                       (loop (cdr tail) (cons (car tail) head) (- n 1)))))))
      (if (null? preds)
        ;; thunk
        (proc)
        (receive (tail-args head-args) (split args (- (length preds) 1))
          (let loop ((head-args head-args) (preds preds))
            (cond
              ((null? head-args)
               (cond
                 ((and variadic? ((car preds) tail-args))
                  (apply proc args))
                 (((car preds) (car tail-args))
                  (apply proc args))
                 (else
                   (error (procedure-data proc)
                          (format #f "precondition violated: ~s with ~s"
                          (procedure-data (car preds))
                          (if variadic? tail-args (car tail-args)))))))
              (((car preds) (car head-args)) 
               (loop (cdr head-args) (cdr preds)))
              (else
                (error (procedure-data proc)
                       (format #f "precondition violated: ~s with ~s"
                       (procedure-data (car preds))
                       (car head-args)))))))))))

;;; (command-checker check doc . docs)
;;; ----------------------------------
;;; check must be a function of the same arguments as the command to be
;;; checked and return an even number of values, i.e. pairs of a
;;; matching query's result, which shows what is to be changed, and a
;;; compare routine comparing that query's result before and after the
;;; call of command.  The rest is for documentation and error-messages
(define (command-checker check doc . docs)
  (lambda (command)
    (cond
      ((eq? command state)
       (apply list doc docs))
      ((not (effects-checked?))
       command)
      (else
        (lambda args
          (let ((olds (map car
                           (chop (call-with-values
                                   (lambda () (apply check args))
                                   list)
                                 2))))
            (apply command args)
            (let ((lst (chop (call-with-values
                               (lambda () (apply check args))
                               list)
                             2)))
              (let loop ((compares (map cadr lst))
                         (olds olds)
                         (news (map car lst)))
                (cond
                  ((null? olds) ; success
                   (void))
                  (((car compares) (car olds) (car news))
                   (loop (cdr compares) (cdr olds) (cdr news)))
                  (else
                    (error (procedure-data command)
                           (format #f "postcondition violated: ~s with args ~s, olds ~s and news ~s"
                                   docs
                                   args
                                   olds
                                   news))))))))))))

;;; (query-checker check doc . docs)
;;; --------------------------------
;;; check is a procedure of the same arguments as the query to be
;;; checked - the checker's only argument - and returns a predicate on
;;; query's returned values, i.e. a procedure of as many arguments as
;;; values are returned. The rest is documentation.
(define (query-checker check doc . docs)
  (lambda (query)
    (cond
      ((eq? query state)
       (apply list doc docs))
      ((not (effects-checked?))
       query)
      (else
        (lambda args
          (let ((results (call-with-values
                           (lambda () (apply query args))
                           list)))
            (if (apply (apply check args) results)
              (apply values results)
              (error (procedure-data query)
                     (format #f
                             "postcondition violated: ~s with args ~s and results ~s"
                             (apply list doc docs) args results)))))))))

;;; (no-checker doc . docs)
;;; -----------------------
;;; in case no effect checks are wanted, this macro can be used. It
;;; provides only documentation and returns its procedure argument
;;; unchecked.
(define (no-checker doc . docs)
  (lambda (proc)
    (if (eq? proc state)
      (apply list doc docs)
      proc)))

(define (method? xpr)
  (and (procedure? xpr)
       ;; with-exception-handler would need call/cc
       (condition-case
         (eq? ((xpr state) 'type) 'method)
         ((exn) #f))))

(define (method-name meth)
  ((meth state) 'name))

;;; (method-assumptions meth)
;;; ------------------------
;;; return the list of predicate names of the method
(define (method-assumptions meth)
  (map procedure-data (cdr ((meth state) 'proc-list))))

(define (method-effects meth)
  ((meth state) 'effects))

;;; (method-variadic? meth)
;;; -----------------------
;;; returns #t if meth is variadic, #f otherwise
(define (method-variadic? meth)
  ((meth state) 'variadic?))

;;; (method-arity meth)
;;; -------------------
;;; return the arity of the method
(define (method-arity meth)
  ((meth state) 'arity))

(define (methods . args)
  (sort
    '(method no-checker query-checker command-checker method?
             method-variadic?  method-arity method-name method-assumptions
             method-effects effects-checked?)
    (lambda (x y)
      (string<? (symbol->string x) (symbol->string y)))))

) ; module methods

(module multi-methods
  (multi-methods (multi-method
                 multi-method-tree-insert multi-method-pair->tree
                 multi-method-tree-action)
                 multi-method? multi-method-variadic?
                 multi-method-empty?  multi-method-arity
                 multi-method-insert! multi-method-keys)

(import scheme
        method-helper
        (only chicken condition-case assert receive gensym error fx>= fx- fx= fx<)
        (only extras format)
        (only data-structures list-of? sort)
        (only lolevel procedure-data))

;;;; (multi-method var . vars)
;;;; -------------------------
;;;; multi-method datatye constructor
;;;; the number of arguments defines the depth of the trees
;;;; Note that variadicity can be changed at first insert
(define-syntax multi-method
  (syntax-rules ()
    ((_ var . vars)
     (let ((proc-tree '())
           (variadic? #f))
       (lambda (arg . args)
         (let ((arity (length '(var . vars)))
               (arglist (apply list arg args)))
           (if (and (null? args) (eq? arg state))
             (lambda (sym)
               (case sym
                 ((proc-tree) proc-tree)
                 ((arity) arity)
                 ((variadic?) variadic?)
                 ((type) 'multi-method)
                 ((method-insert!)
                  (lambda (meth . keys)
                    ;; only at first insert
                    (if (null? proc-tree)
                      (set! variadic? ((meth state) 'variadic?)))
                    (set! proc-tree
                          (apply multi-method-tree-insert
                                 proc-tree
                                 (multi-method-pair->tree ((meth state) 'proc-list))
                                 keys))))
                 (else (error 'multi-method
                              "message not understood"
                              sym))))
             (cond
               ((null? proc-tree)
                (error 'multi-method "empty multi-method"))
               ((and (not variadic?)
                     (not (fx= (length arglist) arity)))
                (error 'multi-method
                       (format #f "arguments ~S don't match arity ~S and variadicity ~S~%"
                               arglist arity variadic?)))
               ((and variadic?
                     (not (fx>= (length arglist) (fx- arity 1))))
                (error 'multi-method
                       (format #f "arguments ~S don't match arity ~S and variadicity ~S~%"
                               arglist arity variadic?)))
               (else
                 (apply
                   ;; find the matching procedure
                   (apply multi-method-tree-action proc-tree variadic? arg args)
                   ;; apply it
                   arg args))))))))))

;; multi-method-tree-insert, multi-method-tree-action and multi-method-pair->tree
;; are only exported with multi-method
(define (multi-method-pair->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 (multi-method-tree-action tree variadic? arg . args)
  (let outer ((tree tree) (arg arg) (args args))
    (if ((list-of? procedure?) (map cadr tree))
      (let inner ((tree tree))
        (cond
          ((null? tree)
           (error 'tree-action "no matching method found"))
          ((and variadic? ((caar tree) (cons arg args)))
           (cadar tree))
          (((caar tree) arg)
           (cadar tree))
          (else (inner (cdr tree)))))
      (let ((subtree (tree-memp (lambda (t) (t arg)) tree)))
        (if (null? subtree)
          (error 'tree-action "no matching method found")
          (outer (cadar subtree) (car args) (cdr args)))))))

(define (multi-method-tree-insert multi-tree 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)
       tree)
      ((null? syms)
       ;; insert at end: (gensym 'end) is never found
       (multi-method-tree-insert multi-tree tree (gensym 'end)))
      (else
        (let ((sym (car syms)) (rest-syms (cdr syms)))
          (receive (tail head) (splitp (lambda (x)
                                         (eq? (procedure-data (car x)) sym))
                                       multi-tree)
            (cond
              ((null? tail)
               (reverse* head tree))
              ((and (eq? sym (procedure-data (caar tail)))
                    (eq? sym (procedure-data (caar tree))))
               (reverse* head
                         (append (list (list (caar tail)
                                             (apply multi-method-tree-insert
                                                    (cadar tail)
                                                    (cadar tree)
                                                    rest-syms)))
                                 (cdr tail))))
              (else
                (reverse* head (cons (car tree) tail))))))))))

;; internal
(define (tree-memp ok? tree)
  (let loop ((tree tree))
    (cond
      ((null? tree)
       '())
      ((procedure? (cadar tree))
       tree)
      ((ok? (caar tree))
       tree)
      (else
        (loop (cdr tree))))))

;;; (multi-method? xpr)
;;; -------------------
;;; type predicate for multi-methods
(define (multi-method? xpr)
  (and (procedure? xpr)
       ;; with-exception-handler would need call/cc
       (condition-case
         (eq? ((xpr state) 'type) 'multi-method)
         ((exn) #f))))

;;; (multi-method-variadic? multi)
;;; ------------------------------
;;; returns #t if the multi-method is variadic
(define (multi-method-variadic? multi)
  ((multi state) 'variadic?))

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

(define (multi-method-insert! multi meth . keys)
  (assert (fx= ((multi state) 'arity) ((meth state) 'arity)))
  (if (not (null? ((multi state) 'proc-tree)))
    (assert (fx= ((multi state) 'variadic?) ((meth state) 'variadic?))))
  (apply ((multi state) 'method-insert!) meth keys))

(define (multi-method-keys multi . keys)
  (assert (fx< (length keys) ((multi state) 'arity)))
  (letrec ((tree-memq (lambda (sym tree)
                        (let loop ((tree tree))
                          (cond
                            ((null? tree)
                             '())
                            ((procedure? (cadar tree))
                             tree)
                            ((eq? sym (procedure-data ;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 state) 'proc-tree))
               (keys keys))
      (if (null? keys)
        (map procedure-data (map car proc-tree))
        (let ((mpt (tree-ref proc-tree (car keys))))
          (loop mpt (cdr keys)))))))

(define (multi-method-empty? multi)
  (null? (multi-method-keys multi)))

(define (multi-methods . args)
  (sort '(multi-method multi-method? multi-method-variadic?
                       multi-method-arity multi-method-insert!
                       multi-method-keys)
        (lambda (x y)
          (string<? (symbol->string x) (symbol->string y)))))

) ; module multi-methods