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

;;;

(module type-errors (;export
  ;;
  make-error-type-message
  signal-type-error
  error-argument-type
  warning-argument-type
  ;;
  error-fixnum
  error-positive-fixnum
  error-cardinal-fixnum
  error-flonum
  error-integer
  error-positive-integer
  error-cardinal-integer
  error-number
  error-positive-number
  error-cardinal-number
  error-procedure
  error-input-port
  error-output-port
  error-list
  error-pair
  error-blob
  error-vector
  error-structure
  error-symbol
  error-keyword
  error-string
  error-char
  error-boolean
  ;;
  (define-error-type error-argument-type))

(import scheme chicken (only data-structures ->string conc))

(declare
  (usual-integrations)
  (fixnum)
  (inline)
  (local)
  (no-procedure-checks)
  (no-bound-checks)
  (constant
    vowel?)
  (bound-to-procedure
    ##sys#signal-hook) )

;;;

;;

(define (vowel? ch) (and (memq ch '(#\a #\e #\i #\o #\u)) #t))

(define (make-error-type-message kndnam #!optional argnam)
  (let ((kndnam (->string kndnam)))
    (conc
      "bad"
      #\space (if argnam (conc #\` argnam #\' #\space) "")
      "argument type - not"
      #\space (if (vowel? (string-ref kndnam 0)) "an" "a")
      #\space kndnam) ) )

;;

(define (signal-type-error loc msg . objs)
  (apply ##sys#signal-hook #:type-error loc msg objs) )

;;

(define (error-argument-type loc obj kndnam #!optional argnam)
  (signal-type-error loc (make-error-type-message kndnam argnam) obj) )

;;

(define (warning-argument-type loc obj typnam #!optional argnam)
  (warning
    (string-append 
      (if loc (conc #\( (symbol->string loc) #\) #\space) "")
      (conc (apply make-error-type-message typnam argnam) #\: #\space)
      (->string obj))) )

;;

; <symbol>          : <msg> is "<symbol>"
; <symbol> <string> : <msg> is <string>
; ->
; (define (error-<symbol> loc obj #!optional argnam)
;   (error-argument-type loc obj <msg> argnam) )

(define-syntax define-error-type
  (lambda (form r c)
    (let (($define (r 'define))
          ($#!optional (r '#!optional))
          ($error-argument-type (r 'error-argument-type)) )
      (let* ((typ (cadr form))
             (typstr (symbol->string typ))
             (msg (if (null? (cddr form)) typstr (caddr form)))
             (nam (string->symbol (string-append "error-" typstr))) )
        `(,$define (,nam loc obj ,$#!optional argnam)
           (,$error-argument-type loc obj ,msg argnam) ) ) ) ) )

;;

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

(define (error-structure loc obj tag #!optional argnam)
	(error-argument-type loc obj (conc "structure" #\space tag) argnam) )

) ;module type-errors