; 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.
; 
; Last update: Jan 10, 2013
;
;Design by Contract
;==================
;
;Design by Contract is a programming paradigm invented by Bertrand Meyer
;for his purely Object Oriented Language Eiffel. The objective is to
;reduce the complexity of software by means of a clear separation of
;concerns between its suppliers and clients. One of the rules is: Never
;do a check an both sides of the abstraction barrier. To achieve this,
;Eiffel fosters a style, in which each routine clearly specifies, what
;are the assumptions (preconditions) of a routine and what are its
;propositions (postconditions). Moreover, the runtime system is able to
;check these conditions. If now a routine call fails because of illegal
;arguments, the client is to blame, but if it fails with violated
;propositions, it is the supplier's fault. The routine's body will not
;even be accessed with violated assumptions , and the routine will not
;even return with violated propositions.
;
;The metaphor is that of a contract between supplier and client. The
;supplier guarantees correct results, provided the client fulfills his
;duties. If not, the supplier is not obligated to start work at all. As
;in real life, both parties need a copy of the contract, and there must
;be a judge in case of troubles. Translated to programming, this means,
;the contract needs to be documented, and both parties can trust each
;other, so that they need not - and should not - check the other's
;duties, the runtime system will do it. It's a bit like proving a
;mathematical theorem: to prove its proposition, the assumptions can be 
;taken for granted. Without them, the proposition is simply meaningless.
;
;There is still another metaphor of Meyer's, Command-Query-Separation.
;That means, that the programmer should never write routines both for a
;result and for a side-effect (like the ++ operators in C). Instead, two
;routines should be written, one that returns a result, the other that
;changes state. The former are called queries by Meyer, the latter
;commands (because all of Eiffel's routines operate on objects, they
;either query or command its state). In Scheme we have functions without
;side-effect, written for their results only (the recommended style), and
;state-changing procedures, which are normally denoted with a trailing
;bang. But independent of the different terminology, the principle
;applies to Scheme as well, in fact to every language.
;
;Design by Contract is such a powerful paradigm, that anybody, who ever
;has programmed in Eiffel, would like to have it in his favorite
;language. Outside the Lisp family of languages, you where out of luck,
;but Lisps, being programmable programming languages, allow you to add
;to the language what you miss. In Lisp, you are a language designer as
;well as a programmer! In what follows, you'll see, how easy it is to
;implement Design by Contract in Chicken Scheme. 
;
;The syntax
;----------
;Let's start with the interface. We'll package the needed macros and
;procedures into a Chicken module called dbc. The fundamental macros are
;called contract (for functions), command-contract (for commands) and
;macro-contract (for low-level macros). Their syntax is similar to the
;syntax of syntax-rules as explained below.
;
;There are no contracts for high-level macros, because the pattern
;matching process of syntax-rules can be considered as precondition
;checking. After all, macros are evaluated at compile time, i.e. before
;runtime. Hence they have no access to an expression's value, they treat
;expressions as literal lists.  Hence preconditions can only check, if
;those expressions match some patterns .... But something should be done
;to document the accepted patterns, since syntax-rules' error messages
;
;  during expansion of (name ...) - no rule matches form: (name ...)
;
;don't help without documentation: push-contract! can provide the
;necessary documentation by hand.
;
;These contract macros are used with 
;
;  (define-with-contract contract-expression procedure)
;
;for both procedure types and
;
;  (define-macro-with-contract
;    macro-contract-expression
;    macro-transformer-expression). 
;
;All these macro calls must be enclosed into two other macro calls,
;(init-dbc) and (exit-dbc-with name). The first macro is unhygienic,
;because its call will define a global variable, *contracts*, to collect
;the documentation of contracts, and it will initialize a special
;exception-handler. The second macro call will store the collected
;documentation in a dispatcher, name, by convention the module name. The
;call (name) will then list the documented symbols, (name 'sym) the
;documentation of sym and (name "file") will store the whole
;documentation in file in a wiki like format.
;
;Note that automatic documentation is essential for design by contract.
;After all, a contract without a contract document, the "small print" is
;useless.
;
;Above I said, that the syntax of contract expressions is similar to the
;syntax of syntax-rules
;
;  (syntax-rules (key ...) (pat0 tpl0) (pat1 tpl1) ...)
;
;where pat0, pat1 ... are nested lambda-lists and tpl0, tpl1, ... the
;templates to be generated by the macro for the first pattern matching
;the macro's use.
;
;A macro-contract expression changes the templates to matchers, i.e.
;routines which check, if the macro expansion matches some nested
;lambda-list and eventually some additional conditions. The matches?
;macro will do that job.  Moreover, the patterns pat0, pat1 ... must
;eventually pass some fenders to be considered a match (this is an
;extension well known from syntax-case macros of R6RS). And last, but
;not least, low-level macros might be unhygienic, and the "dirty"
;symbols which pollute the name-space should be documented. In sum,
;macro-contracts look like this, if we use pseudo-variables .. and ....
;(besides ellipses, ..., "repeat the pattern on the left zero or many
;times") to mean "repeat the pattern to the left zero or one times, or
;one or many times" respectively.
;
;  (macro-contract hyg ... (key ...) (pat fender matcher) ....)
;
;Functions without side effect are controlled by
;
;  (contract (result ....) (pat pre post) ....)
;
;where pat is now a lambda-list, pre a precondition and post a
;postcondition, pre an expression checking the pattern variables of pat,
;and post checking the results. Note that pre might refer to the pattern
;variables of pat and post additionally to result .... Since strings and
;symbols always return #t, you can use them as pre- or postconditions.

;Commands, i.e. procedures without return values, which change some
;state variables instead, require the most complex contract. We need to
;check, which state variables are changed and how. Now, commands are
;usually accompanied by queries, which are functions operating on a
;subset of the command's arguments and returning state. For example,
;to set-car! corresponds car, which might be used to control what
;set-car! changes. In sum, command-contract looks as follows
;
;  (command-contract ((old new query) ....) (pat pre post) ....)
;
;where now post operates on the pattern variables of pat as well as the
;old and new variables. But here remains one twist: The macro can't
;know, on which subset of the command's arguments the queries operate.
;We must tell it. In other words, the supplied queries must be lifted to
;command's argument list.
;
;Note that despite their similarities, there is one difference in the
;postconditions of these three contract macros: procedure contracts
;require an expression, while macro-contract requires a predicate, i.e.
;a function.
;
;Example
;-------
;Let's consider an example, a function with two return values, Euclid's
;integer division. Note that this contract proves, that the function
;does what it is supposed to do!
;
;  (define-with-contract q+r
;    (contract (q r) ; two results
;      ((_ m n)
;       (and ; preconditions
;        (integer? m) (not (negative? m))
;        (integer? n) (positive? n)
;        (<= n m))
;       (and ; postconditions
;         (integer? q)
;         (integer? r)
;         (= (+ (* q n) r) m))))
;    (lambda (m n)
;      (let loop ((q 0) (r m))
;        (if (< r n)
;          (values q r)
;          (loop (+ q 1) (- r n))))))
;
;How do all these macros work?
;-----------------------------
;Well, it's relatively simple. The three contract expressions return a
;pair, consisting of its own documentation and a procedure. The latter
;does the actual checks. In other words, it accepts another procedure as
;argument and returns that very procedure with annotated checks.
;
;The two defines store the contract's documentation in *contracts*,
;supplied by init-dbc, and apply the contract's checker to its procedure
;argument.
;
;Isn't that a lot of checking code, you might ask, and you are right.
;Therefor there is a parameter, contract-check-level, with values 0, 1
;and 2, meaning "no checks at all, only documentation", "check only
;preconditions" or "check everything" respectively. The default is 1,
;but in the developing phase you'll probably set it to 2. 
;
;How to organize your code?
;--------------------------
;Typically, you'll place the raw definitions without any defenses in one
;module, say raw-foo, and import their names with a prefix into another
;one, say foo, to add the contracts to them. These prefixed names can
;than be used in foo's contracts as well. The second module, foo, is
;the one to be exported.
;
;The splitting into two modules has several advantages.
;First, it helps developing. Usually, you'll have an idea, what a
;routine should do and how to implement it. At this stage, you needn't
;bother about "defensing programming" or anything like this, you can add
;the defenses later. You can already test your ideas incrementally and
;see if they do what they are supposed to do.

;Second, you wouldn't like to check these defenses again and again in
;your own routines, in particular in recursive ones. It's better to do
;the checks only once from outside.

;Third, you can enhance your old modules with contracts later one
;without touching the code.

;Fourth, if you like driving without a security belt and are concerned
;with speed, you can import raw-foo instead of foo into client code.

;Another example
;---------------
;The following rather contrieved example may clarify this. The resulting
;module, foo, contains all three contract types.
;
;  (module raw-foo (adder adder! freeze)
;  (import scheme)
;  (define state 0)
;  (define (adder) state)
;  (define (adder! n) (set! state (+ state n)))
;  (define (freeze form inject compare?)
;    `(lambda () ,(cadr form)))
;  ) ; end raw-foo
;
;Then you define and add the contracts to the prefixed names

;  (module foo (adder adder! freeze)
;  (import (prefix (except raw-foo freeze) "%"))
;  (import-for-syntax (prefix (only raw-foo freeze) "%"))
;  (define-with-contract adder
;    (contract (result)
;      ((_) #t (number? result)))
;    %adder)
;  (define-with-contract adder!
;    (command-contract ((old new (lambda (n) (%adder))))
;      ((_ n) (number? n) (= new (+ old n))))
;    %adder!)
;  (define-macro-with-contract freeze
;    (macro-contract () ((_ x) #t (matches? (lambda () x))))
;    (ir-macro-transformer %freeze))
;  ) ; end foo

(module dbc
  (dbc init-dbc
       (exit-dbc-with document-contracts)
       contract
       command-contract
       macro-contract
       define-with-contract
       define-macro-with-contract
       matches?
       push-contract!
       contract-check-level lambda-list? nested-lambda-list?
       make-dispatcher string-repeat
       contract? contract-check-level
       make-contract-condition contract-condition? contract-location
       contract-text contract-arguments contract-condition-handler)

  (import scheme chicken
          (only data-structures sort list-of?)
          (only extras printf sprintf))
  (import-for-syntax
    (only data-structures compress list-of?)
    (only chicken condition-case))

;;;;;;;;;; internal simplified version of bind ;;;;;;;;;;;;;;;
;;; (bind pat seq (where . fender) .. xpr . xprs)
;;; ---------------------------------------------
;;; binds pattern variables of pat to correspondign subexpressions
;;; of seq and executes body xpr . xprs in this context
(define-syntax bind
  (ir-macro-transformer
    (lambda (form inject compare?)
      ;; destructure and helpers
      (let (
        (pat (cadr form))
        (seq (caddr form))
        (body (cdddr form))
        (fender?
          (lambda (x)
            (and (list? x) (not (null? x)) (compare? (car x) 'where))))
        )
        (letrec (
            (checks '()) ; to be populated by destruc
            (destruc
              (lambda (pat seq)
                (cond
                  ((null? pat)
                   (set! checks (cons `(null? ,seq) checks))
                   '())
                  ((symbol? pat) `((,pat ,seq)))
                  ((pair? pat) (append (destruc (car pat) `(car ,seq))
                                       (destruc (cdr pat) `(cdr ,seq))))
                  )))
          )
          (let (
            (body (if (fender? (car body)) (cdr body) body))
            (fender (if (fender? (car body)) (cons 'and (cdar body)) #t))
            )
            (let* ((decls (destruc pat seq))
                   (vars (map car (butlast decls))))
              `(let ,decls
                 (if (and (not (memq #f ,(cons 'list checks)))
                          ((lambda ,vars ,fender) ,@vars))
                     ((lambda ,vars ,@body) ,@vars)
                    (error 'bind
                            (sprintf
                             "expression ~a doesn't match pattern ~a where ~a~%"
                             ,seq ',pat ',fender)))))))))))

;;;;;;;;;; internal simplified version of bind-case ;;;;;;;;;;;;;;;
;;; (bind-case seq (pat (where . fenders) .. xpr . xprs) ....)
;;; ----------------------------------------------------------
;;; Checks if seq matches pattern pat [satisfying fenders] ...
;;; in sequence, binds the pattern variables of the first matching
;;; pattern to corresponding subexpressions of seq and executes
;;; corresponding body xpr . xprs
(define-syntax bind-case
  (syntax-rules (where)
    ((_ seq (pat (where . fenders) xpr . xprs))
     (bind pat seq (where . fenders) xpr . xprs))
    ((_ seq (pat xpr . xprs))
     (bind pat seq xpr . xprs))
    ((_ seq clause . clauses)
     (condition-case
       (bind-case seq clause)
       ((exn)
        (bind-case seq . clauses))))))

;;; (matches? pat . fenders)
;;; ------------------------
;;; to be used for postconditions in macro-contract
(define-syntax matches?
  (syntax-rules ()
    ((_ pat . fenders)
     (lambda (form)
       (condition-case
         (bind pat form (where . fenders) #t)
         ((exn) #f))))))

;;; (init-dbc)
;;; ----------
;;; unhygienic, introduces *contracts* into the namespace
(define-syntax init-dbc
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((contracts (inject '*contracts*))) ; unhygienic
      `(begin
         (define ,contracts '())
         (current-exception-handler contract-condition-handler))))))

;;; (exit-dbc-with name)
;;; --------------------
;;; defines documentation dispatcher name
(define-syntax exit-dbc-with
  (syntax-rules ()
    ((_ name)
     (begin
       (define name (document-contracts *contracts*))
       (set! *contracts* '())))))

;;; (contract (result ....) (pat pre post) ....)
;;; --------------------------------------------
;;; for proper functions
(define-syntax contract
  (ir-macro-transformer
    (lambda (form inject compare?)
      (if
        ;; check syntax
        (and
          (> (length form) 2)
          ((list-of? symbol?) (cadr form))
          (not (null? (cadr form)))
          ((list-of? (lambda (x)
                       (and (list? x)
                            (= (length x) 3)
                            (pair? (car x))
                            (symbol? (caar x))
                            ;; lambda-list?
                            (let loop ((y (cdar x)))
                              (cond
                                ((null? y) #t)
                                ((symbol? y) #t)
                                ((pair? y)
                                 (and (symbol? (car y))
                                      (loop (cdr y))))
                                (else #f))))))
           (cddr form)))
        ;; destructure
        (let ((results (cadr form)) (rules (cddr form)))
          (let ((pats (map car rules))
                (pres (map cadr rules))
                (posts (map caddr rules)))
            ;; write code
            `(lambda (sym)
               (cons
                 (list sym (cons 'procedure ',(cdr form)))
                 (lambda (proc)
                   (lambda args
                     (case (contract-check-level)
                       ((0) ; no checks
                        (apply proc (listify args)))
                       ((1 2)
                        ;; check preconditions and return a procedure
                        ;; which can check postconditions
                        (let (
                          (post (check-pres
                                  `(,sym ,@args)
                                  ,pats
                                  ,pres
                                  ,(map (lambda (p)
                                          `(lambda ,results ,p))
                                        posts)))
                          )
                          (call-with-values
                            ;; preconditions are already checked
                            (lambda () (apply proc (listify args)))
                            (lambda ,results
                              (case (contract-check-level)
                                ((1)
                                 (values ,@results))
                                ((2)
                                 ;; check postconditions
                                 (if (post ,@results)
                                   (values ,@results)
                                   (signal
                                     (make-contract-condition
                                       sym ',posts
                                       "where" ',results "is"
                                       (list ,@results)))))))))))))))))
        (syntax-error 'contract
"\nuse (contract (result ....) (pat pre post) ....)")))))

;;; (command-contract ((old new query) ....) (pat pre post) ....)
;;; -------------------------------------------------------------
;;; for state changing procedures
(define-syntax command-contract
  (ir-macro-transformer
    (lambda (form inject compare?)
      ;; check syntax
      (if
        (and
          (> (length form) 2)
          ((list-of? (lambda (e)
                       (list? e)
                       (= (length e) 3)
                       (symbol? (car e))
                       (symbol? (cadr e))))
           (cadr form))
          ((list-of? (lambda (x)
                       (and (list? x)
                            (= (length x) 3)
                            (pair? (car x))
                            (symbol? (caar x))
                            ;; lambda-list?
                            (let loop ((y (cdar x)))
                              (cond
                                ((null? y) #t)
                                ((symbol? y) #t)
                                ((pair? y)
                                 (and (symbol? (car y))
                                      (loop (cdr y))))
                                (else #f))))))
           (cddr form)))
        ;; destructure
        (let ((effects (cadr form)) (rules (cddr form)))
          (let (
            (olds (map car effects))
            (news (map cadr effects))
            (queries (map caddr effects))
            (pats (map car rules))
            (pres (map cadr rules))
            (posts (map caddr rules))
            )
            ;; write code
            `(lambda (sym)
               (cons
                 (list sym (cons 'procedure ',(cdr form)))
                 (lambda (proc)
                   (lambda args
                     (case (contract-check-level)
                       ((0) ; no checks
                        (apply proc (listify args)))
                       ((1 2)
                        ;; check preconditions and return a procedure
                        ;; which can check postconditions
                        (let (
                          (post (check-pres
                                  `(,sym ,@args)
                                  ,pats
                                  ,pres
                                  ,(map (lambda (p)
                                          `(lambda ,(append olds news) ,p))
                                        posts)))
                          )
                          ;; define old states
                          (let ,(map (lambda (e)
                                       `(,(car e); ,(caddr e)))
                                         (apply ,(caddr e)
                                                (listify args))))
                                     effects)
                            ;; preconditions are already checked
                            (apply proc (listify args))
                            (case (contract-check-level)
                              ((1) (void))
                              ((2) ; check postconditions
                               ;; define new states after having applied proc
                               (let ,(map (lambda (e)
                                            `(,(cadr e); ,(caddr e)))
                                              (apply ,(caddr e)
                                                     (listify args))))
                                          effects)
                                 (if (post ,@olds ,@news)
                                   (void)
                                   (signal
                                     (make-contract-condition
                                       sym ',posts
                                       "where arguments are"
                                       args
                                       "states are"
                                       (map (lambda (var val) `(,var ,val))
                                            ',news (list ,@news))
                                       "and old states"
                                       (map (lambda (var val) `(,var ,val))
                                            ',olds (list ,@olds))
                                       ))))))))))))))))
        (syntax-error 'command-contract
"\nuse (command-contract ((old new query) ....) (pat pre post) ....)")))))

;;;(macro-contract hyg ... (key ...) (pat fender xpr) ....)
;;;-----------------------------------------------------------
;;;where hyg is an unhygienic symbol,
;;;key a keyword, pat is a nested lambda-list, fender an expression to
;;;be satisfied for pat to match the macro-code  and xpr an expression
;;;on the single argument result.
;;;For low-level macros.
(define-syntax macro-contract
  (ir-macro-transformer
    (lambda (form inject compare?)
      ;; check syntax
      (if
        (and
          (> (length form) 2)
          (>= (length (compress (map list? form) form)) 2)
          ((list-of? symbol?)
           (car (compress (map list? form) form)))
          ((list-of? (lambda (x)
                       (and (list? x)
                            (= (length x) 3)
                            (pair? (car x))
                            (symbol? (caar x))
                            ;; nested lambda-list?
                            (let loop ((y (cdar x)))
                              (cond
                                ((null? y) #t)
                                ((symbol? y) #t)
                                ((pair? y)
                                 (and (loop (car y))
                                      (loop (cdr y))))
                                (else #f))))))
           (cdr (compress (map list? form) form))))
        ;; destructure form
        (let ((hygs (cdr (compress (map symbol? form) form)))
              (keys (car (compress (map list? form) form)))
              (rules (cdr (compress (map list? form) form))))
          (let ((pats (map car rules))
                (pres (map cadr rules))
                (posts (map caddr rules)))
            ;; write code
            `(lambda (sym)
               (cons
                 (list sym (cons 'macro ',(cdr form)))
                 (lambda (proc)
                   (lambda (f x c?)
                     (case (contract-check-level)
                       ((0) ; no checks
                        (proc f x c?))
                       ((1 2)
                        ;; check preconditions and return a procedure
                        ;; which can check postconditions
                        (let (
                          (post (check-pres
                                  `(,sym ,@(cdr f))
                                  ,pats
                                  ,pres
                                  ,(map (lambda (p)
                                          `(lambda () ,p))
                                        posts)))
                          )
                          ;; preconditions are already checked
                          (let ((expansion (proc f x c?)))
                            (case (contract-check-level)
                              ((1) expansion)
                              ((2)
                               ;; check postconditions
                               (if ((post) expansion)
                                 expansion
                                 (signal
                                   (make-contract-condition
                                     sym ;',posts
                                     `(,sym ,@(cdr f))
                                     "expands to"
                                     expansion
                                     "which isn't accepted by any"
                                     ',(map (lambda (p) `(,p))
                                           posts)
                                     )))))))))))))))
        (syntax-error 'macro-contract
"\nuse (macro-contract hyg ... (key ...) (form fender  matcher) ....)")))))

;;; (define-with-contract name contr proc)
;;; --------------------------------------
;;; for all procedures
(define-syntax define-with-contract
  (syntax-rules () ; ok
    ((_ name contr proc)
     (begin
       (push-contract! (car (contr 'name)))
       (define name ((cdr (contr 'name)) proc))))))

;;; (define-macro-with-contract)
;;; ----------------------------
;;; for low-level macros
(define-syntax define-macro-with-contract
  (syntax-rules () ; ok
    ((_ name contr (transformer-type proc))
     (begin
       (push-contract! (car (contr 'name)))
       (define-syntax name
         (transformer-type ((cdr (contr 'name)) proc)))))))

;;; (push-contract contract-docu)
;;; -----------------------------
;;; for high level macros
(define-syntax push-contract!
  (syntax-rules ()
    ((_ contract-docu)
     (set! *contracts* (cons contract-docu *contracts*)))))

;;; (check-pres form pats pres posts)
;;; ---------------------------------
;;; helper for contracts
(define-syntax check-pres
  (ir-macro-transformer
    (lambda (f i c?)
      (let (
        (form (cadr f))
        (pats (caddr f))
        (pres (cadddr f))
        (posts (car (cddddr f)))
        )
        `(condition-case
           (bind-case ,form
             ,@(map (lambda (a p q)
                      `(,a (where ,p) ,q))
                    pats pres posts))
           ((exn)
            (signal
              (make-contract-condition
                (car ,form)
                ,form
                "didn't match any pattern"
                ',pats
                "or precondition"
                ',pres))))))))

;;; (listify pseudolist)
;;; --------------------
;;; helper for contracts
(define-syntax listify
  (syntax-rules ()
    ((_ ()) '())
    ((_ (a . b)) (cons a (listify b)))
    ((_ a)  (apply list a))))

;;; (contract-check-level arg ..)
;;; -----------------------------
;;; parameter
(define contract-check-level
  (make-parameter 1 (lambda (x)
                   (if (and (integer? x)
                            (exact? x)
                            (<= 0 x 2))
                     x
                     1))))
;;; *contracts*
;;; -----------
;;; global variable to store the documentation of contracts
(define *contracts*
  '(
     (contract-check-level
       (parameter (or (result)
                      ((old new (lambda (x) (contract-check-level)))))
         ((_)
          (and (integer? result) (<= 0 result 2)
"0: no checks, 1: preconditions checked, 2: pre- and postconditions checked"))
         ((_ x)
          (and (integer? x) (<= 0 x 2))
          (= new x))))
     (matches?
       (macro ()
         ((_ pat . fenders)
          (nested-lambda-list? pat)
          "procedure returning #t if its argument matches pat with fenders")))
     (init-dbc
       (macro *contracts* ()
         ((_)
          #t
          "initializes exception handler")))
     (exit-dbc-with
       (macro ()
         ((_ name)
          (symbol? name)
          "saves *contracts* in dispatcher name")))
     (contract
       (macro ()
         ((_ (result ....) (pat pre post) ....)
          (lambda-list? pat)
          (contract? result))))
     (command-contract
       (macro ()
         ((_ ((old new query) ....) (pat pre post) ....)
          (lambda-list? pat)
          (contract? result))))
     (macro-contract
       (macro ()
          ((_ hyg ... (key ...) (pat fender matcher) ....)
           (and (nested-lambda-list? pat) (procedure? matcher))
           (contract? result))))
     (define-with-contract
       (macro ()
         ((_ name contr proc)
          (contract? contr)
          (begin
            (push-contract! (car (contr 'name)))
            (define name ((cdr (contr 'name)) proc))))))
     (define-macro-with-contract
       (macro ()
         ((_ name contr (transformer-type proc))
          (contract? contr)
          (begin
            (push-contract! (car (contr 'name)))
            (define-syntax name
              (transformer-type ((cdr (contr 'name)) proc)))))))
     (push-contract!
       (macro ()
         ((_ contract-docu)
          "documentation of a contract"
          (matches? (set! *contracts*
                          (cons contract-docu *contracts*))))))
  ))

;;; (make-dispatcher alist)
;;; ---------------------------
;;; transforms an association list
;;; into a dispatcher routine, which prints the association's values.
(define make-dispatcher
  (lambda (alst)
    (let ((syms (sort (map car alst)
                      (lambda (x y)
                        (string<? (symbol->string x)
                                  (symbol->string y))))))
      (case-lambda 
        (() syms)
        ((arg)
         (cond
           ((symbol? arg)
            ;; show documentation of this symbol
            (let ((found (assq arg alst)))
              (if found
                found ;(cdr found)
                (begin
                  (print "not found in ")
                  syms))))
           ((string? arg)
            ;; print documentation to file named arg
            (with-output-to-file arg
              (lambda ()
                (for-each
                  (lambda (x) (print (car (memq x alst))))
                  syms))))
           (else
             (error 'make-dispatcher
                    "not a symbol or filename-string" arg))))))))
(push-contract!
  '(make-dispatcher
     (procedure (result)
       ((_ alist)
        ((list-of? list?) alist)
        (procedure? result)))))

;;; (string-repeat str n)
;;; ---------------------
(define (string-repeat str n)
  (let loop ((n n) (result ""))
    (if (zero? n)
      result
      (loop (- n 1) (string-append result str)))))
(push-contract!
  '(string-repeat
     (procedure (result)
       ((_ str n)
        (and (string? str) (not (negative? n)))
        (string? result)))))

;;; (lambda-list? xpr)
;;; ------------------
(define (lambda-list? xpr)
  (or (null? xpr)
   (symbol? xpr)
   (and (pair? xpr)
        (symbol? (car xpr))
        (lambda-list? (cdr xpr)))))
(push-contract!
  '(lambda-list?
     (procedure (result)
       ((_ xpr)
        #t
        (boolean? result)))))

;;; (nested-lambda-list? xpr)
;;; -------------------------
(define (nested-lambda-list? xpr)
  (or (null? xpr)
   (symbol? xpr)
   (and (pair? xpr)
        (not (null? (car xpr)))
        (nested-lambda-list? (car xpr))
        (nested-lambda-list? (cdr xpr)))))
(push-contract!
  '(nested-lambda-list?
     (procedure (result)
       ((_ xpr)
        #t
        (boolean? result)))))

;;; (splitp ok? lst)
;;; ----------------
;;; hidden
(define (splitp ok? lst)
  (let loop ((head '()) (tail lst))
    (cond
      ((null? tail)
       (list (reverse head) tail))
      ((ok? (car tail))
       (list (reverse head) tail))
      (else
        (loop (cons (car tail) head) (cdr tail))))))

;;; (document-contracts contracts)
;;; ------------------------------
;;; used by exit-dbc to save *contracts*
(define (document-contracts contracts)
  (let ((dispatcher (make-dispatcher contracts)))
    (case-lambda
      (()
       (dispatcher))
      ((arg)
       (cond
         ((symbol? arg)
          (dispatcher arg))
         ((string? arg)
          ;; print wiki documentation to file named arg
           (with-output-to-file arg
             (lambda ()
               (for-each
                 (lambda (v)
                   (bind (name (type . rest)) (dispatcher v)
                   ;(let ((disp (dispatcher v)))
                   ;  (let ((name (car disp))
                   ;        (type (cadr disp))
                   ;        (rest (cddr disp)))
                     (bind (hyg tail) (splitp list? rest)
                     ;(let (
                     ;  (hyg (compress (map symbol? rest) rest))
                     ;  (tail (compress (map list? rest) rest))
                     ;  )
                       (bind (what . rules) tail
                       ;(let ((what (car tail)) (rules (cdr tail)))
                         (let ((calls
                                 ;; replace _ by name in call structure
                                 (map (lambda (x) `(,name ,@(cdr x)))
                                      (map car rules))))
                           (print "==== " name)
                           (printf "~%<~S>~S</~S>~%~%~A~?~A~S~%~%"
                                   type
                                   (if (= (length rules) 1)
                                     (car calls)
                                     (cons 'or calls))
                                   type
                                   (cond
                                     ((and (eq? type 'macro) (null?  hyg))
                                      "hygienic, ")
                                     ((eq? type 'macro)
                                      "unhygienic, exports ")
                                     (else ""))
                                   (string-repeat "~S " (length hyg))
                                   hyg
                                   (case type
                                     ((macro) "keys ")
                                     ((procedure); "effect ")
                                      (if ((list-of? symbol?) what)
                                        "function "
                                        "command "))
                                     (else ""))
                                   what)
                           (print "<enscript highlight=scheme>")
                           (for-each
                             (lambda (rule)
                               (printf "~%~S~?"
                                       `(,name ,@(cdar rule))
                                       (string-repeat "~%  ~S"
                                                      (length (cdr rule)))
                                       (cdr rule))
                               (newline))
                             rules)
                           ;(newline)
                           (print "\n</enscript>\n"))))));   )
                 (dispatcher)))))
         (else
           (error 'document-contract
                  "not a symbol or a string"
                  arg))
         )))))
;(push-contract!
;  '(document-contracts
;     (procedure (result)
;       ((_ contracts)
;        (list? contracts) "usually  *contracts*"
;        (procedure? result) "dispatcher routine"))))

;;; (contract? xpr)
;;; ---------------
(define (contract? xpr)
  (and (procedure? xpr)
       (condition-case
         (case (caadar (xpr (string->symbol "")))
           ((macro procedure) #t)
           (else #f))
         ((exn) #f))))
(push-contract!
  '(contract?
     (procedure (result)
       ((_ xpr)
        #t
        (boolean? result)))))


;;; (make-contract-condition location text . arguments)
;;; ---------------------------------------------------
(define (make-contract-condition location text . arguments)
  (make-property-condition 'contract
                           'location location
                           'text text
                           'arguments arguments))
(push-contract!
  '(make-contract-condition
     (procedure (result)
       ((_ location text . arguments)
        (and (symbol? location) (string? text))
        (condition? result)))))

;;; (contract-condition? xpr)
;;; -------------------------
(define contract-condition? (condition-predicate 'contract))
(push-contract!
  '(contract-condition?
     (procedure (result)
       ((_ xpr)
        #t
        (boolean? result)))))

;;; (contract-text cnd)
;;; -------------------
(define contract-text (condition-property-accessor 'contract 'text))
(push-contract!
  '(contract-text
     (procedure (result)
       ((_ cnd)
        (contract-condition? cnd)
        (string? result)))))

;;; (contract-location cnd)
;;; -----------------------
(define contract-location (condition-property-accessor 'contract 'location))
(push-contract!
  '(contract-location
     (procedure (result)
       ((_ cnd)
        (contract-condition? cnd)
        (symbol? result)))))

;;; (contract-arguments cnd)
;;; ------------------------
(define contract-arguments (condition-property-accessor 'contract 'arguments))
(push-contract!
  '(contract-arguments
     (procedure (result)
       ((_ cnd)
        (contract-condition? cnd)
        (list? result)))))

;;; (contract-condition-handler exn)
;;; --------------------------------
(define contract-condition-handler
  (let ((old-handler (current-exception-handler)))
    (lambda (exn)
       (if (contract-condition? exn)
         (begin
            (print "\nContract violation in (" (contract-location exn) "):")
            (print (contract-text exn))
            (for-each print (contract-arguments exn))
            (newline)
            (abort (make-property-condition
                     'exn
                     'message "exception-handler returned")))
         (old-handler exn)))))
(push-contract!
  '(contract-condition-handler
     (procedure (result)
       ((_ exn)
        (condition? exn)
        "result of handled exeption"))))

;;; (dbc sym ..)
;;; -----------
;;; documentation procedure. Returns the list of available symbols if
;;; called with no arguments, the call structure of a routine, if
;;; called with the routine's name,a symbol, or prints
;;; wiki-documentation to its string argument
(define dbc (document-contracts *contracts*))

) ; module dbc