(module check mzscheme
  (require mzlib/class
	   (prefix wx: "kernel.ss")
	   "wx.ss"
	   "const.ss")
  (provide (protect (all-defined)))

  (define (who->name who)
    (cond
     [(symbol? who) who]
     [(eq? (car who) 'method) (string->symbol (format "~a in ~a" (caddr who) (cadr who)))]
     [(eq? (car who) 'iconstructor) (iconstructor-name (cadr who))]
     [else (constructor-name (cadr who))]))

  (define (label-string? s)
    (and (string? s) 
	 (let ([l (string-length s)])
	   (and l
		(<= 0 l 200)))))

  (define (constructor-name who)
    (string->symbol (format "initialization for ~a%" who)))

  (define (iconstructor-name who)
    (string->symbol (format "initialization for a class that implements ~a<%>" who)))

  (define (check-orientation cwho l)
    (check-style cwho '(vertical horizontal) '(vertical-label horizontal-label deleted) l))

  (define (check-container-ready cwho p)
    (when p
      (let ([wx (mred->wx p)])
	(unless wx
	  (raise-mismatch-error (who->name cwho)
				"container is not yet fully initialized: " 
				p)))))

  (define (check-instance who class class-name false-ok? v)
    (unless (or (and false-ok? (not v)) (is-a? v class))
      (raise-type-error (who->name who) (format "~a object~a" class-name (if false-ok? " or #f" "")) v)))

  (define (check-string/false who str)
    (unless (or (not str) (string? str))
      (raise-type-error (who->name who) "string or #f" str)))

  (define (check-path who str)
    (unless (path-string? str)
      (raise-type-error (who->name who) "path or string" str)))

  (define (check-path/false who str)
    (unless (or (not str) (path-string? str))
      (raise-type-error (who->name who) "path, string, or #f" str)))

  (define (check-string who str)
    (unless (string? str)
      (raise-type-error (who->name who) "string" str)))

  (define (check-label-string who str)
    (unless (label-string? str)
      (raise-type-error (who->name who) "string (up to 200 characters)" str)))

  (define (check-label-string/false who str)
    (unless (or (not str) (label-string? str))
      (raise-type-error (who->name who) "string  (up to 200 characters) or #f" str)))

  (define (check-char/false who c)
    (unless (or (not c) (char? c))
      (raise-type-error (who->name who) "character or #f" c)))

  (define (check-callback who callback)
    (unless (and (procedure? callback)
		 (procedure-arity-includes? callback 2))
      (raise-type-error (who->name who) "procedure of arity 2" callback)))

  (define (check-callback1 who callback)
    (unless (and (procedure? callback)
		 (procedure-arity-includes? callback 1))
      (raise-type-error (who->name who) "procedure of arity 1" callback)))

  (define (check-bounded-integer min max false-ok?)
    (lambda (who range)
      (unless (or (and false-ok? (not range))
		  (and (integer? range) (exact? range) (<= min range max)))
	(raise-type-error (who->name who) 
			  (format "exact integer in [~a, ~a]~a"
				  min max
				  (if false-ok? " or #f" ""))
			  range))))

  (define check-range-integer (check-bounded-integer 0 10000 #f))

  (define check-slider-integer (check-bounded-integer -10000 10000 #f))

  (define check-init-pos-integer (check-bounded-integer -10000 10000 #t))

  (define check-margin-integer (check-bounded-integer 0 1000 #f))

  (define check-gauge-integer (check-bounded-integer 1 10000 #f))

  (define (check-wheel-step cwho wheel-step)
    (when (and wheel-step
	       (not (and (integer? wheel-step)
			 (exact? wheel-step)
			 (<= 1 wheel-step 10000))))
      (raise-type-error (who->name cwho)
			"#f or exact integer in [1,10000]"
			wheel-step)))

  (define (check-fraction who x)
    (unless (and (real? x) (<= 0.0 x 1.0))
      (raise-type-error (who->name who) 
			"real number in [0.0, 1.0]"
			x)))

  (define (-check-non-negative-integer who i false-ok?)
    (when (or i (not false-ok?))
      (unless (and (integer? i) (exact? i) (not (negative? i)))
	(raise-type-error (who->name who) 
			  (if false-ok?
			      "non-negative exact integeror #f" 
			      "non-negative exact integer" )
			  i))))

  (define (check-non-negative-integer who i)
    (-check-non-negative-integer who i #f))

  (define (check-non-negative-integer/false who i)
    (-check-non-negative-integer who i #t))

  (define check-dimension (check-bounded-integer 0 10000 #t))
  (define check-non#f-dimension (check-bounded-integer 0 10000 #f))

  (define (check-label-string-or-bitmap who label)
    (unless (or (label-string? label) (is-a? label wx:bitmap%))
      (raise-type-error (who->name who) "string (up to 200 characters) or bitmap% object" label)))

  (define (check-label-string-or-bitmap/false who label)
    (unless (or (not label) (label-string? label) (is-a? label wx:bitmap%))
      (raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or #f" label)))

  (define (check-label-string/bitmap/iconsym who label)
    (unless (or (label-string? label) (is-a? label wx:bitmap%)
		(memq label '(app caution stop)))
      (raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or icon symbol" label)))

  (define (check-font who f)
    (unless (or (eq? f no-val) (f . is-a? . wx:font%))
      (raise-type-error (who->name who) "font% object" f)))

  (define (check-style who reqd other-allowed style)
    (unless (and (list? style) (andmap symbol? style))
      (raise-type-error (who->name who) "list of style symbols" style))
    (when reqd
      (letrec ([or-together (lambda (l)
			      (if (= (length l) 2)
				  (format "~a or ~a" (car l) (cadr l))
				  (let loop ([l l])
				    (if (null? (cdr l))
					(format "or ~a" (car l))
					(format "~a, ~a" (car l) (loop (cdr l)))))))])
	(unless (ormap (lambda (i) (memq i reqd)) style)
	  (raise-type-error (who->name who)
			    (format "style list, missing ~a"
				    (if (= (length reqd) 1)
					(car reqd)
					(string-append
					 "one of "
					 (or-together reqd))))
			    style))))
    (if (and (not reqd) (null? other-allowed))
	(unless (null? style)
	  (raise-type-error (who->name who) "empty style list" style))
	(let* ([l (append (or reqd null) other-allowed)]
	       [bad (ormap (lambda (x) (if (memq x l) #f x)) style)])
	  (when bad
	    (raise-type-error (who->name who) (format "style list, ~e not allowed" bad) style))
	  (let loop ([l style])
	    (unless (null? l)
	      (when (memq (car l) (cdr l))
		(raise-type-error (who->name who) (format "style list, ~e allowed only once" (car l)) style))
	      (loop (cdr l))))))))