; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
;
; Last update: June 10, 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. This should be a
;procedure, which when called with a special argument produces documentation
;and when called with a procedure argument, e.g. the car of the
;proc-list, returns that very procedure with postconditins checked.
;But since postcondition checks might be expensive, the application of
;it can be controlled by the parameter effects-checked?

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

(module methods
  (methods method query-checker command-checker method? method-variadic?
           method-arity method-name method-assumptions method-effects
           effects-checked?)

(import scheme
        method-helper
        (only chicken receive condition-case gensym make-parameter conjoin error)
        (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))))

;;; (command-checker check0 check1 ...)
;;; -----------------------------------
;;; Each check must be a function of the same arguments as the command
;;; to be checked and return three values, the query which shows what is
;;; to be changed, a compare routine comparing query's result before and
;;; after the call of command, and documentation.
(define-syntax command-checker
  (syntax-rules ()
    ((_ check0 check1 ...)
     (lambda (command)
       (lambda args
         (let* ((checks (list check0 check1 ...))
                (docs
                   (map (lambda (check)
                          (call-with-values
                            (lambda () (apply check args))
                            (lambda (q c doc) doc)))
                        checks)))
           (cond
             ((eq? command state)
              docs)
             ((effects-checked?)
              (let ((olds
                      (map (lambda (check)
                             (call-with-values
                               (lambda () (apply check args))
                               (lambda (query c d) query)))
                           checks)))
                (apply command args)
                (let loop ((olds olds)
                           (news
                             (map (lambda (check)
                                    (call-with-values
                                      (lambda () (apply check args))
                                      (lambda (query c d) query)))
                                  checks))
                           (compares
                             (map (lambda (check)
                                    (call-with-values
                                      (lambda () (apply check args))
                                      (lambda (q compare d) compare)))
                                  checks))
                           (docs docs))
                    (cond
                      ((null? compares)
                       (void)) ; success
                      (((car compares) (car olds) (car news))
                       (loop (cdr olds) (cdr news) (cdr compares) (cdr docs)))
                      (else
                        (error (procedure-data command)
                               "postcondition violated"
                               docs))))))
             (else
               (apply command args)))))))))

;;; (query-checker (name0 check0 . checks0) (name1 check1 . checks1) ...)
;;; ---------------------------------------------------------------------
;;; Check postconditions of a query, i.e. a function.
;;; The number of clauses of query-checker must be equal to the number
;;; of return values of the query.
;;; The checks are predicates, which test the return values.
;;; The names are symbols to be used for documentation purposes and
;;; readable error messages.
(define-syntax query-checker
  (syntax-rules ()
    ((_ (name0 check0 . checks0)
        (name1 check1 . checks1)
        ...)
     (lambda (query)
       (if (eq? query state)
         (list name0 name1 ...)
         (if (effects-checked?)
           (lambda args
             (let ((original-results
                     (call-with-values
                       (lambda () (apply query args))
                       list)))
               (let loop ((results original-results)
                          (checks (list (conjoin check0 . checks0)
                                        (conjoin check1 . checks1)
                                        ...))
                          (names (list name0 name1 ...)))
                 (cond
                   ((null? checks) ; success
                    (apply values original-results))
                   (((car checks) (car results))
                    (loop (cdr results) (cdr checks) (cdr names)))
                   (else
                     (error (procedure-data query)
                            "postcondition violated"
                            `(,(car names) ,(car results))))))))
           query))))))

;;; (method [variadic?]
;;;         (proc-name proc effect-checker doc . docs)
;;;         (name pred . preds)
;;;         ...)
;;; --------------------------------------------------
;;; method datatye constructor.
;;; proc is the actual procedure which is ultimately called
;;; effect-checker checks proc's return values or side-effects,
;;; i.e. either query-checker or command-checker is used,
;;; name a symbol describing the predicate(conjoin pred . preds) which
;;; do the argument checks.
;;; Note that the doc variable is used to decide if the method is
;;; variadic: If must be #f for method to be variadic.
(define-syntax method
  (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)))
        (check-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
                (apply proc args)
                (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)
                                  "precondition violated"
                                  (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)
                               "precondition violated"
                               (procedure-data (car preds))
                               (car head-args))))))))))
        )
        (let (
          (proc-name (car head))
          (proc (cadr head))
          (checker (caddr head))
          (docs (cdddr head))
          (names (map car tail))
          (preds (map cdr tail))
          )
     `(let ((proc-list
              (list
                (,checker (extend-procedure ,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))
               ((doc) (list ,@docs))
               ((arity) (length (cdr proc-list)))
               ((variadic?) ,variadic?)
               ((name) ,proc-name)
               ((type) 'method)
               (else (error (procedure-data ,proc-name)
                            "message not understood"
                            sym))))
           (apply ',check-and-call proc-list ,variadic? args)))))))))

(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)
  (let ((lst '(method query-checker command-checker method? method-variadic?
               method-arity method-name method-assumptions method-effects
               effects-checked?)))
    (if (null? args)
      lst
      (case (car args)
        ((method)
         '(macro ()
            ((_ [variadic?]
                (proc-name proc effect-checker doc . docs)
                (name pred . preds)
                ...)
             "proc is the actual procedure, effect-checker one of
 command-checke or query-checker, preds are predicates to
 check args in sequence, variadic? defaults to #f"
             (method? result))))
        ((command-checker)
         '(macro ()
            ((_ check0 check1 ...)
             "checks are procedures of the same arguments as the command to check returning three values - query-call, compare-proc, doc-string  -  needed for checking"
             "returns the command in case of successfull tests")))
        ((query-checker)
         '(macro ()
            ((_ (name0 check0 . checks0) (name1 check1 . checks1) ...)
             "check0, checks0 are predicates to test result0 ... of the query"
             "returns the query in case of successfull tests")))
        ((method?)
         '(procedure (result)
            ((_ xpr)
             #t
             (boolean? result))))
        ((method-variadic?)
         '(procedure (result)
            ((_ meth)
             (method? meth)
             (boolean? result))))
        ((method-arity)
         '(procedure (result)
            ((_ meth)
             (method? meth)
             (fixnum? result))))
        ((method-name)
         '(procedure (result)
            ((_ meth)
             (method? meth)
             (symbol? result))))
        ((method-assumptions)
         '(procedure (result)
            ((_ meth)
             (method? meth)
             ((list-of? symbol?) result))))
        ((method-effects)
         '(procedure (result)
            ((_ meth)
             (method? meth)
             ((list-of? symbol?) result))))
        ((effects-checked?)
         '(parameter (boolean)
            ((_ [yes?])
             (boolean? yes?)
             "only if yes? is true, effects of queries or commands are checked")))
        (else lst)))))

) ; module methods

(module multi-methods
  (multi-methods multi-method 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 gensym error fx= fx<)
        (only lolevel procedure-data))
(import-for-syntax (only chicken receive)
                   ;method-helper
                   (only data-structures list-of?))

;;;; (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
  (ir-macro-transformer
    (lambda (form inject compare?)
      (letrec (
        (pair->tree
          (lambda (pair)
            (let loop ((rest (cdr pair)))
              (if (null? (cdr rest))
                (list (list (car rest) (car pair)))
                (list (cons (car rest)
                            (list (loop (cdr rest)))))))))
        (tree-memp
          (lambda (ok? tree)
            (let loop ((tree tree))
              (cond
                ((null? tree)
                 '())
                ((procedure? (cadar tree))
                 tree)
                ((ok? (caar tree))
                 tree)
                (else
                  (loop (cdr tree)))))))
        (tree-action
          (lambda (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))))))))
        (tree-insert
          (lambda (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
                 (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 tree-insert
                                                              (cadar tail)
                                                              (cadar tree)
                                                              rest-syms)))
                                           (cdr tail))))
                        (else
                          (reverse* head (cons (car tree) tail)))))))))))
        )
        `(let ((proc-tree '())
               (variadic? #f))
           (lambda (arg . args)
             (if (and (null? args) (eq? arg state))
               (lambda (sym)
                 (case sym
                   ((proc-tree) proc-tree)
                   ((arity) (length (apply list ',(cadr form) ',(cddr form))))
                   ((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 ',tree-insert
                                   proc-tree
                                   (',pair->tree ((meth state) 'proc-list))
                                   keys))))
                   (else (error 'multi-method
                                "message not understood"
                                sym))))
               (apply
                 ;; find the matching procedure
                 (apply ',tree-action proc-tree variadic? arg args)
                 ;; apply it
                 arg args))))))))

;;; (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)
  (let ((lst '(multi-method multi-method? multi-method-variadic?
               multi-method-arity multi-method-insert!
               multi-method-keys)))
    (if (null? args)
      lst
      (case (car args)
        ((multi-method)
         '(macro ()
            ((_ var . vars)
             #t
             "constructor: creates an empty multi-method of arity given
 by its arguments")))
        ((multi-method?)
         '(procedure (result)
            ((_ xpr)
             #t
             (boolean? result))))
        ((multi-method-empty?)
         '(procedure (result)
            ((_ multi)
             (multi-method? multi)
             (boolean? result))))
        ((multi-method-variadic?)
         '(procedure (result)
            ((_ multi)
             (multi-method? multi)
             (boolean? result))))
        ((multi-method-arity)
         '(procedure (result)
            ((_ multi)
             (multi-method? multi)
             (boolean? result))))
        ((multi-method-keys)
         '(procedure (result)
            ((_ multi key ...)
             (multi-method? multi)
             (and (list-of? symbol?) result)
             "predicate names of checking nth arg, fulfilling key0 ...  key(- n 1)")))
        ((multi-method-insert!)
         '(command (proc-tree)
            ((_ multi meth key ...)
             (and (multi-method? multi) (method? meth)
                  (= (method-arity meth) (multi-method-arity multi))
                  (if (not (multi-method-empty? multi))
                    (eq? (method-variadic? meth) (multi-method-variadic?  multi))))
             "updates multi's proc-tree at the appropriate key level")))
        (else lst)))))

) ; module multi-methods