(require-library dbc)

;;; the implementation module doesn't contain any contract information
(module raw-foo
  (id add quotient+remainder single? single single-ref adder
      single-set! efreeze ifreeze ior alambda)

(import scheme chicken dbc)

(define (id x) x)

;; function
(define add +)

(define adder
  (let ((state 0))
    (lambda args
      (if (null? args)
        state
        (set! state (+ state (car args)))))))

;;; function with multiple return values
(define (quotient+remainder m n)
  (let loop ((q 0) (r m))
    (if (< r n)
      (values q r)
      (loop (+ q 1) (- r n)))))

;;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 (single? xpr)
  (and (procedure? xpr)
       (condition-case (eq? 'single (xpr (lambda (a b c) a)))
         ((exn) #f))))

;;; constructor
(define (single xpr)
  (lambda (sel)
    (sel 'single xpr (lambda (new) (set! xpr new)))))

;;; query
(define (single-ref sg)
  (sg (lambda (a b c) b)))

;;; command
(define (single-set! sg xpr)
  ((sg (lambda (a b c) c)) xpr))

;;; macro-transformers
(define (efreeze form rename compare?)
  `(,(rename 'lambda) () ,(cadr form)))

(define (ifreeze form inject compare?)
  `(lambda () ,(cadr form)))

(define (alambda form inject compare?)
  (let (
    (args (cadr form))
    (xpr (caddr form))
    (xprs (cdddr form))
    (self (inject 'self))
    )
    `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
       ,self)))

(define ior
  (lambda (form i c)
    (let ((args (cdr form)))
      (cond
         ((null? args) #f)
         ((null? (cdr args)) (car args))
         (else
           (let ((x (car args)))
             `(if ,x ,x ,(ior `(_ ,@(cdr args)) i c))))))))

) ; module raw-foo


;; prefix the exported symbols of the implementation module
;; and use the prefixed symbols in contracts
(module foo
  (id add quotient+remainder single? single single-ref adder adder!
      single-set! efreeze ifreeze sfreeze ior alambda)
(import scheme chicken
        (prefix (except raw-foo alambda efreeze ifreeze ior) "%")
        dbc
        (only data-structures list-of?))
(import-for-syntax (only dbc macro-contract matches?)
                   (prefix (only raw-foo alambda efreeze ifreeze ior) "%"))

(contract-check-level 2)
(init-dbc)

(define-with-contract id
  (contract (result) ((_ x) (odd? x) (even? result)))
  %id)

(define-with-contract add
  (contract (result)
    ((_ a . b)
     (and (number? a) ((list-of? number?) b))
     (and (number? result) (= result (+ a (apply + b))))))
  %add)

;; query
(define-with-contract adder
  (contract (result)
    ((_) #t (number? result)))
  (lambda () (%adder)))

;; command
(define-with-contract adder!
  (command-contract ((old new (lambda (arg) (%adder))))
    ((_ arg)
     (number? arg)
     (= new (+ arg old))))
  (lambda (arg) (%adder arg)))

;; multiple results
(define-with-contract quotient+remainder
  (contract (q r) ; two results
    ((_ m n)
     (and
       (integer? m) (not (negative? m))
       (integer? n) (positive? n)
       (<= n m))
     (and
       (integer? q)
       (integer? r)
       (= (+ (* q n) r) m))))
  %quotient+remainder)

;; predicate
(define-with-contract single?
  (contract (result)
    ((_ xpr)
     #t
     (boolean? result)))
  %single?)

;; constructor
(define-with-contract single
  (contract (result)
    ((_ xpr)
     'package-the-value-of-xpr-into-a-single-object
     (%single? result)))
  %single)

;; query
(define-with-contract single-ref
  (contract (result)
    ((_ sg)
     (%single? sg)
     'state-of-sg))
  %single-ref)

;;; command
(define-with-contract single-set!
  (command-contract ((old new (lambda (sg xpr) (%single-ref sg))))
    ((_ sg xpr)
     (%single? sg)
     (equal? new xpr)))
  %single-set!)


(define-syntax sfreeze
  (syntax-rules ()
    ((_ x) (lambda () x))))
(push-contract!
  '(sfreeze
     (macro ()
       ((_ x)
        #t
        (lambda () x)))))

(define-macro-with-contract ifreeze
  (macro-contract () ((_ x) #t (matches? (lambda () x))))
  (ir-macro-transformer %ifreeze))

(define-macro-with-contract efreeze
  (macro-contract () ((_ x) #t (matches? (lambda () x))))
  (er-macro-transformer %efreeze))

(define-macro-with-contract ior
  (macro-contract ()
    ((_) #t (lambda (expansion) (not expansion)))
    ((_ x) #t (lambda (expansion) (equal? expansion x)))
    ((_ x . xs)
     #t
     (matches? (if x y z) (equal? x y))))
  (ir-macro-transformer %ior))

(define-macro-with-contract alambda
  (macro-contract self ()
    ((_ args xpr . xprs)
     #t
     (matches? (letrec ((self (lambda args xpr . xprs))) self))))
  (ir-macro-transformer %alambda))

(exit-dbc-with foo)

) ; module foo

(import foo dbc)

(define-syntax run-tests
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let (
        (run (lambda (lst)
               (let loop ((lst lst) (n 0))
                 (if (null? lst)
                   n
                   (if (eval (car lst))
                     (begin
                       (print "passed ... " (car lst))
                       (loop (cdr lst) n))
                     (begin
                       (print "FAILED !!! " (car lst))
                       (loop (cdr lst) (+ n 1))))))))
        )
        `(begin
           (print "\nTesting ...")
           (print "-----------")
           (let ((n (,run ',(cdr form))))
             (print "-----------")
             (if (zero?  n)
               (print "All tests passed\n")
               (print n " test(s) failed!!!\n"))))))))
(define sg (single 5))

(run-tests
  ((matches? (a b) (odd? a)) '(1 2)) 
  (not ((matches? (a b) (even? a)) '(1 2))) 
  ((matches? (a b)) '(1 2))
  (not ((matches? (x)) '(name 1)))
  (not ((matches? (x y) (number? x)) '(name 1)))
  ((matches? (_ x)) '(name 1))
  (not ((matches? (_ x)) '(name 1 2)))
  ((matches? (x (y (z) u) v)) '(1 (2 (3) 4) 5))
  (not ((matches? (x (y (z) u) v) (boolean? z)) '(1 (2 (3) 4) 5)))
  (lambda-list? 'x)
  (lambda-list? '(x y))
  (lambda-list? '(x y . z))
  (not (lambda-list? 1))
  (nested-lambda-list? '(x (y . z) w))
  (nested-lambda-list? '(x (y . z) . w))
  (nested-lambda-list? '((a (b (c (d . e)))) (y . z) . w))
  (not (nested-lambda-list? 1))
  ((list-of? number?) '(1 2 3))
  ((list-of? number?) '())
  (not ((list-of? number?) '(1 #f 3)))
  (= (add 1) 1)
  (= (add 1 2) 3)
  (condition-case (add 1 2 3)
    (var () (if (contract-condition? var) #t #f)))
  (equal? (call-with-values
            (lambda () (quotient+remainder 5 3))
            list) '(1 2))
  (= (begin (adder! 5) (adder)) 5)
  (= (begin (adder! 3) (adder)) 8)
  (single? (single 3))
  (single? sg)
  (not (single? 5))
  (= (single-ref sg) 5)
  (= (begin (single-set! sg 3) (single-ref sg)) 3)
  (= ((alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) 5) 120)
  (not (ior))
  (not (ior #f #f))
  (= (ior #f 2) 2)
  (= ((efreeze 3)) 3)
  (= ((ifreeze 3)) 3)
  (= ((sfreeze 3)) 3)
;  (condition-case (ifreeze 3 4)
;    ((exn syntax) #t))
;    (var () (if (contract-condition? var) #t #f)))
)