(library (Nietsche syntax contract)
  (export
   ->
   listof vectorof
   any/c or/c
   integer-in fixnum-in flonum-in char-in
   define/contract)
  (import (rnrs (6))
          (only (Nietzsche data list)
                every))
  ;; auxiliary keyword ->
  (define-syntax ->
    (lambda (x)
      (syntax-violation #f "misplaced aux keyword" x)))
  ;;;;;;;;;;;;;;;;;;;;
  ;; Useful predicate creators
  ;;;;;;;;;;;;;;;;;;;;
  (define (listof pred?)
    (lambda (x)
      (if (list? x)
          (every pred? x)
          #f)))

  (define (vectorof pred?)
    (lambda (x)
      (let ([len (vector-length x)])
        (let loop ([i 0])
          (cond
           [(= i len) #t]
           [(pred? (vector-ref x i)) (loop (+ i 1))]
           [else #f])))))

  (define (any/c x)
    #t)

  (define (or/c . preds)
    (lambda (x)
      (let loop ([preds preds])
        (cond
         [(null? preds) #f]
         [((car preds) x)]
         [else (loop (cdr preds))]))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Number predicate creators ;;;;;;;
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (in-range/c a b pred? st? bt? expected)
    (lambda (x)
      (if (and (pred? a) (pred? b))
          (and (bt? x a) (st? x b))
          (raise "error"))))

  (define (between/c a b)
    (in-range/c a b real? <= >= 'real))
  (define (integer-in a b)
    (in-range/c a b integer? <= >= 'integer))
  (define (fixnum-in a b)
    (in-range/c a b fixnum? fx<=? fx>=? 'fixnum))
  (define (flonum-in a b)
    (in-range/c a b flonum? fl<=? fl>=? 'flonum))
  (define (char-in a b)
    (in-range/c a b char? char<=? char>=? 'char))

  (define-syntax define/contract
    (syntax-rules (->)
      [(define/contract (id var ...)
         (-> pred? ... return-pred?) body ...)
       (define (id var ...)
         (define (%INTERNAL_PROC)
           body ...)
         (unless (pred? var) (error define/contract "contract error")) ...
         (let ([%return-value (%INTERNAL_PROC)])
           (if (return-pred? %return-value)
               %return-value
               (error 'define/contract "contract error"))))])))

(library (Nietsche syntax contract off)
  (export define/contract
          ->
          listof vectorof
          or/c any/c
          integer-in fixnum-in flonum-in char-in)
  (import (rnrs (6))
          (except (Nietsche syntax contract)
                  define/contract))

  (define-syntax define/contract
    (syntax-rules (->)
      [(_ (id var ...) (-> pred? ... return-pred?) body ...)
       (define (id var ...)
         body ...)])))