;;; File: contracts-run.scm

(require 'contracts)
(import contracts)

(define (true? x) #t)

(doclist '())

;;; Example with procedure body wrapped into a let expression
(define-with-contract adder! ;ok!
  (let ((state 0))
    (contract (adder! arg)
      "adds its argument to its state"
      (domain: (number? arg))
      (effect: (old state (+ old arg)))
      #;(effect: (old state (+ old arg 1)))) ;wrong on purpose
    (lambda (arg)
      (set! state (+ state arg))
      ;; export state for error checking
      (set! exported state)
      )))

;; to check adder!
(define exported #f)

;Example: An implementation of the single datatype 
;-------------------------------------------------
;Here is a simple, but realistic example, in which commands and queries
;are involved, the single datatype, which does the same what boxes do.

;;; predicate
(define-with-contract (single? xpr)
  "check, if xpr evaluates to a single"
  (and (procedure? xpr)
       (condition-case (eq? 'single (xpr (lambda (a b c) a)))
         ((exn) #f))))

;;; constructor
(define-with-contract (single xpr)
  "package the value of xpr into a single object"
  (domain: (true? xpr))
  (range: (single? result))
  (lambda (sel)
    (sel 'single xpr (lambda (new) (set! xpr new)))))

;;; query
(define-with-contract (single-state sg)
  "returns the state of the single object sg"
  (domain: (single? sg))
  (range: (true? result))
  (sg (lambda (a b c) b)))

;;; command
(define-with-contract (single-state! sg arg)
  "replaces state of sg with arg"
  (domain: (single? sg) (true? arg))
  #;(effect: (state (single-state sg) (+ arg 1))) ; wrong on purpose
  (effect: (state (single-state sg) arg))
  ((sg (lambda (a b c) c)) arg))

(define contracts-test (doclist->dispatcher (doclist)))

(define sg (single 5))

(define (run)
  (if 
    (and
      (= (begin (adder! 5) exported) 5)
      (= (begin (adder! 3) exported) 8)
      (eq? (single? (single 3)) #t)
      (eq? (single? sg) #t)
      (eq? (single? 5) #f)
      (= (single-state sg) 5)
      (= (begin (single-state! sg 3) (single-state sg)) 3))
    (print "All tests passed")
    (print "##### Some tests failed #####")))

(run)