;;;; type-checks.scm
;;;; Kon Lovett, Apr '09

;;;

(module type-checks (;export
  check-fixnum
  check-positive-fixnum
  check-cardinal-fixnum
  check-flonum
  check-integer
  check-positive-integer
  check-cardinal-integer
  check-number
  check-positive-number
  check-cardinal-number
  check-procedure
  check-input-port
  check-output-port
  check-list
  check-pair
  check-blob
  check-vector
  check-structure
  check-symbol
  check-keyword
  check-string
  check-char
  check-boolean
  check-alist
  ;;
  check-minimum-argument-count
  check-argument-count
  ;;
  define-check-type define-check+error-type)

  (import chicken scheme (only srfi-1 every) type-errors)

  (require-library srfi-1 type-errors)

  (declare
    (bound-to-procedure ##sys#structure?) )

;;

(cond-expand
  (unsafe
 
    (define-syntax define-check-type
      (lambda (form r c)
        (let ((_define (r 'define)))
          (let* ((typ (cadr form))
                 (nam (string->symbol (string-append "check-" (symbol->string typ)))) )
            `(,_define (,nam . _) (begin) ) ) ) ) )

    (define (check-positive-fixnum . _) (begin))
    (define (check-cardinal-fixnum . _) (begin))
    (define (check-positive-integer . _) (begin))
    (define (check-cardinal-integer . _) (begin))
    (define (check-positive-number . _) (begin))
    (define (check-cardinal-number . _) (begin))
    (define (check-structure . _) (begin)) )

  (else

    ;;

    ; <symbol>          : <pred> is '<symbol>?'
    ; <symbol> <symbol> : <pred> is <symbol>
    ; ->
    ; (define (check-<symbol> loc obj #!optional argnam)
    ;   (unless (<pred> obj)
    ;     (error-<symbol> loc obj argnam) ) )

    (define-syntax define-check-type
      (lambda (form r c)
        (let ((_define (r 'define))
              (_#!optional (r '#!optional)) )
          (let* ((typ (cadr form))
                 (typstr (symbol->string typ))
                 (pred (if (not (null? (cddr form))) (caddr form) (string->symbol (string-append typstr "?"))))
                 (nam (string->symbol (string-append "check-" typstr)))
                 (errnam (string->symbol (string-append "error-" typstr))) )
            `(,_define (,nam loc obj ,_#!optional argnam)
               (unless (,pred obj)
                 (,errnam loc obj argnam) ) ) ) ) ) )
    ;;

    (define (check-positive-fixnum loc obj #!optional argnam)
      (unless (and (fixnum? obj) (fx< 0 obj))
        (error-positive-fixnum loc obj argnam) ) )

    (define (check-cardinal-fixnum loc obj #!optional argnam)
      (unless (and (fixnum? obj) (fx<= 0 obj))
        (error-cardinal-fixnum loc obj argnam) ) )

    ;;

    (define (check-positive-integer loc obj #!optional argnam)
      (unless (and (integer? obj) (positive? obj))
        (error-positive-integer loc obj argnam) ) )

    (define (check-cardinal-integer loc obj #!optional argnam)
      (unless (and (integer? obj) (<= 0 obj))
        (error-cardinal-integer loc obj argnam) ) )

    ;;

    (define (check-positive-number loc obj #!optional argnam)
      (unless (positive? obj)
        (error-positive-number loc obj argnam) ) )

    (define (check-cardinal-number loc obj #!optional argnam)
      (unless (<= 0 obj)
        (error-cardinal-number loc obj argnam) ) )

    ;;

    (define (check-structure loc obj tag #!optional argnam)
      (unless (##sys#structure? obj tag)
        (error-structure loc obj tag argnam) ) ) ) )

;;

(define-check-type fixnum)
(define-check-type flonum)
(define-check-type integer)
(define-check-type number)
(define-check-type symbol)
(define-check-type keyword)
(define-check-type string)
(define-check-type char)
(define-check-type boolean)
(define-check-type procedure)
(define-check-type input-port)
(define-check-type output-port)
(define-check-type list)
(define-check-type pair)
(define-check-type blob)
(define-check-type vector)

(define (alist? obj) (or (null? obj) (and (pair? obj) (every pair? obj))))
(define-check-type alist)

(define (check-minimum-argument-count loc argc minargc)
  (unless (fx<= minargc argc)
    (error-minimum-argument-count loc argc minargc)) )

(define (check-argument-count loc argc maxargc)
  (unless (fx<= argc maxargc)
    (error-argument-count loc argc maxargc)) )

;;

; <type-symbol> [<type-predicate> [<message-string>]]

(define-syntax define-check+error-type
  (lambda (form r c)
    (let ((_define-check-type (r 'define-check-type))
          (_define-error-type (r 'define-error-type)) )
      (let* ((typ (cadr form))
             (pred (and (not (null? (cddr form))) (caddr form))) 
             (mesg (and pred (not (null? (cdddr form))) (cadddr form))) )
        `(begin
           (,_define-error-type ,typ ,@(if mesg `(,mesg) '()))
           (,_define-check-type ,typ ,@(if pred `(,pred) '())) ) ) ) ) )

) ;module type-checks