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

;; Issues
;;
;; - Chicken Generic Arithmetic!
;;
;; - check-negative-* (< X 0), check-non-positive-* (<= X 0)

(module type-checks

(;export
  define-check-type
  define-check+error-type
  check-defined-value
  check-bound-value
  check-number
  check-fixnum
  check-flonum
  check-integer
  check-real
  check-complex
  check-rational
  check-exact
  check-inexact
  check-positive-fixnum check-natural-fixnum check-negative-fixnum check-non-positive-fixnum
  check-positive-integer check-natural-integer check-negative-integer check-non-positive-integer
  check-positive-number check-natural-number check-negative-number check-non-positive-number
  check-procedure check-closure
  check-input-port
  check-output-port
  check-list
  check-pair
  check-blob
  check-vector
  check-structure
  check-record
  check-record-type
  check-symbol
  check-keyword
  check-string
  check-char
  check-boolean
  check-alist
  check-minimum-argument-count check-argument-count
  check-closed-interval check-open-interval
  check-half-closed-interval check-half-open-interval
  check-range
  ;
  check-cardinal-fixnum
  check-cardinal-integer
  check-cardinal-number)

(import chicken scheme)
(use type-errors)

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

;;

(define-syntax unbound-value
	(syntax-rules ()
		((_)
			(##sys#slot '##sys#arbitrary-unbound-symbol 0) ) ) )

(define-syntax unbound-value?
	(syntax-rules ()
		((_ ?val)
			(eq? (unbound-value) ?val) ) ) )

(define-syntax unbound?
	(syntax-rules ()
		((_ ?sym)
			(unbound-value? (##sys#slot ?sym 0)) ) ) )

;;

;maybe a problem with expansion environment namespace pollution
(define-for-syntax (symbolize . elts)
  (string->symbol (apply conc (map strip-syntax elts))) )

;;

(cond-expand

  (unsafe

    (define-syntax define-check-type
      (er-macro-transformer
        (lambda (frm rnm cmp)
          (let ((_define (rnm 'define)))
            (let* (
              (typ (cadr frm))
              (nam (string->symbol (string-append "check-" (symbol->string typ)))) )
              `(,_define (,nam loc obj . _) obj) ) ) ) ) )

    ;;Backwards
    (define (check-cardinal-fixnum loc obj . _) obj)
    (define (check-cardinal-integer loc obj . _) obj)
    (define (check-cardinal-number loc obj . _) obj)

    (define (check-positive-fixnum loc obj . _) obj)
    (define (check-natural-fixnum loc obj . _) obj)
    (define (check-negative-fixnum loc obj . _) obj)
    (define (check-non-positive-fixnum loc obj . _) obj)
    (define (check-positive-integer loc obj . _) obj)
    (define (check-natural-integer loc obj . _) obj)
    (define (check-negative-integer loc obj . _) obj)
    (define (check-non-positive-integer loc obj . _) obj)
    (define (check-positive-number loc obj . _) obj)
    (define (check-natural-number loc obj . _) obj)
    (define (check-negative-number loc obj . _) obj)
    (define (check-non-positive-number loc obj . _) obj)
    (define (check-structure loc obj . _) obj)
    (define (check-record loc obj . _) obj)
    (define (check-record-type loc obj . _) obj)
    (define (check-minimum-argument-count loc obj . _) obj)
    (define (check-argument-count loc obj . _) obj)
    (define (check-closed-interval loc obj . _) obj)
    (define (check-open-interval loc obj . _) obj)
    (define (check-half-closed-interval loc obj . _) obj)
    (define (check-half-open-interval loc obj . _) obj) )

  (else

    ;;These are weak predicates. Only check for structure.

    (export alist? plist?)

    (define (alist? obj)
      (or
        (null? obj)
        (and
          (pair? obj)
          (let loop ((ls obj))
            (or
              (null? ls)
              (and
                ;since anything can be a key no stronger check possible
                (pair? (car ls))
                (loop (cdr ls) ) ) ) ) ) ) )

    (define (plist? obj)
      ;since anything can be a key no stronger check possible
      (and (list? obj) (even? (length obj))) )

    ;;

    ;<symbol>          : <pred> is '<symbol>?'
    ;<symbol> <symbol> : <pred> is <symbol>
    ;->
    ;(define (check-<symbol> loc obj . args)
    ;  (unless (<pred> obj)
    ;    (error-<symbol> loc obj (optional args)))
    ;  obj )

    (define-syntax define-check-type
      (er-macro-transformer
        (lambda (frm rnm cmp)
          (let (
            (_define (rnm 'define))
            (_unless (rnm 'unless))
            (_optional (rnm 'optional)) )
            (let* (
              (typ (cadr frm))
              (typstr (symbol->string typ))
              (pred
                (if (not (null? (cddr frm)))
                  (caddr frm)
                  (string->symbol (string-append typstr "?"))))
              (nam (string->symbol (string-append "check-" typstr)))
              (errnam (string->symbol (string-append "error-" typstr))) )
              `(,_define (,nam loc obj . args)
                 (,_unless (,pred obj)
                   (,errnam loc obj (,_optional args)))
                 obj ) ) ) ) ) )

    ;;Is the object non-void?

    (define (defined-value? obj)
      (not (eq? (void) obj)) )

    ;;Is the object bound to value?

    ;is obj the value from the de-ref of an unbound variable.
    ;could only occur in a rather unsafe calling environnment.

    (define (bound-value? obj)
      (unbound? obj)
      #;
      ((##core#inline "C_unboundvaluep" n) obj) )

    ;;

    (define (check-positive-fixnum loc obj . args)
      (unless (and (fixnum? obj) (fx< 0 obj))
        (error-positive-fixnum loc obj (optional args)))
      obj )

    (define (check-natural-fixnum loc obj . args)
      (unless (and (fixnum? obj) (fx<= 0 obj))
        (error-natural-fixnum loc obj (optional args)))
      obj )

    (define (check-negative-fixnum loc obj . args)
      (unless (and (fixnum? obj) (fx> 0 obj))
        (error-negative-fixnum loc obj (optional args)))
      obj )

    (define (check-non-positive-fixnum loc obj . args)
      (unless (and (fixnum? obj) (fx>= 0 obj))
        (error-non-positive-fixnum loc obj (optional args)))
      obj )

    ;;

    (define (check-positive-integer loc obj . args)
      (unless (and (integer? obj) (positive? obj))
        (error-positive-integer loc obj (optional args)))
      obj )

    (define (check-natural-integer loc obj . args)
      (unless (and (integer? obj) (<= 0 obj))
        (error-natural-integer loc obj (optional args)))
      obj )

    (define (check-negative-integer loc obj . args)
      (unless (and (integer? obj) (negative? obj))
        (error-negative-integer loc obj (optional args)))
      obj )

    (define (check-non-positive-integer loc obj . args)
      (unless (and (integer? obj) (>= 0 obj))
        (error-non-positive-integer loc obj (optional args)))
      obj )

    ;;

    (define (check-positive-number loc obj . args)
      (unless (and (number? obj) (positive? obj))
        (error-positive-number loc obj (optional args)))
      obj )

    (define (check-natural-number loc obj . args)
      (unless (and (number? obj) (<= 0 obj))
        (error-natural-number loc obj (optional args)))
      obj )

    (define (check-negative-number loc obj . args)
      (unless (and (number? obj) (negative? obj))
        (error-negative-number loc obj (optional args)))
      obj )

    (define (check-non-positive-number loc obj . args)
      (unless (and (number? obj) (>= 0 obj))
        (error-non-positive-number loc obj (optional args)))
      obj )

    ;;

    (define (check-structure loc obj tag . args)
      (unless (##sys#structure? obj tag)
        (error-structure loc obj tag (optional args)))
      obj )

    (define (check-record loc obj tag . args)
      (unless (##sys#structure? obj tag)
        (error-record loc obj tag (optional args)))
      obj )

    (define (check-record-type loc obj tag . args)
      (unless (##sys#structure? obj tag)
        (error-record-type loc obj tag (optional args)))
      obj ) ) )

;;

(define-check-type defined-value)
(define-check-type bound-value)

(define-check-type fixnum)
(define-check-type flonum)
(define-check-type integer)
(define-check-type real)
(define-check-type complex)
(define-check-type rational)
(define-check-type exact)
(define-check-type inexact)
(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-closure check-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-check-type plist)
(define-check-type alist)

;closed interval
(define (check-closed-interval loc num min max . args)
  (unless (and (<= min num) (<= num max))
    (error-closed-interval loc num min max (optional args)))
  num )

;open interval
(define (check-open-interval loc num min max . args)
  (unless (and (< min num) (< num max))
    (error-open-interval loc num min max (optional args)))
  num )

;closed+open interval
(define (check-half-open-interval loc num min max . args)
  (unless (and (< min num) (<= num max))
    (error-half-open-interval loc num min max (optional args)))
  num )

;open+closed interval
(define (check-half-closed-interval loc num min max . args)
  (unless (and (<= min num) (< num max))
    (error-half-closed-interval loc num min max (optional args)))
  num)

;check half-closed-interval itself
(define (check-range loc start end . args)
  (unless (<= start end)
    (apply error-range loc start end args) )
  (values start end) )

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

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

;;

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

(define-syntax define-check+error-type
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (let (
        (_define-check-type (rnm 'define-check-type))
        (_define-error-type (rnm 'define-error-type)) )
        (let* (
          (typ (cadr frm))
          (pred (and (not (null? (cddr frm))) (caddr frm)))
          (mesg (and pred (not (null? (cdddr frm))) (cadddr frm))) )
          `(begin
             (,_define-error-type ,typ ,@(if mesg `(,mesg) '()))
             (,_define-check-type ,typ ,@(if pred `(,pred) '())) ) ) ) ) ) )

;; Backwards

(define check-cardinal-fixnum check-natural-fixnum)
(define check-cardinal-integer check-natural-integer)
(define check-cardinal-number check-natural-number)

) ;module type-checks