;;;; type-errors-en.incl.scm  -*- Scheme -*-

;; Notes
;;
;; - The type error message is built so as to `look' like those of the
;; CHICKEN "core". Only with optional information.

;; Issues
;;
;; - Maybe "... not an integer" -> "... integer required" &
;; "... not a list" -> "... list required",
;; or "... not integer", ...

#; ;USED
(;exports
  make-location-message
  make-tagged-kind-message
  make-bad-argument-message
  make-type-name-message
  make-error-type-message
  make-error-interval-message
  make-warning-type-message)
#; ;USED
(import (only (chicken string) ->string))

;;

;w/o SRFI 29 (xtd w/ source/binary) then cond-expand of includes

;in this case never #\y
(define (vowel? ch) (->boolean (memq ch '(#\a #\e #\i #\o #\u))))

(define (1st-letter s) (and (not (zero? (string-length s))) (string-ref s 0)))

(define (indefinite-article s) (if (vowel? (1st-letter s)) "an" "a"))

(define (make-location-message loc)
  (string-append "(" (->string loc) ")") )

(define (make-tagged-kind-message kndnam tag)
	(string-append (->string kndnam) " " (->string tag)) )

(define (make-type-name-message typnam)
  (let ((typstr (->string typnam)))
    (string-append (indefinite-article typstr) " " typstr) ) )

(define (make-bad-argument-message #!optional argnam)
  (if (not argnam)
      "bad argument"
      (string-append "bad `" (->string argnam) "' argument") ) )

(define (type-name-clause typnam)
  (string-append "not " (make-type-name-message typnam)) )

(define (bad-argument-clause argnam)
  (string-append (make-bad-argument-message argnam) " type") )

(define (make-error-type-message typnam #!optional argnam)
  ;a type-error-clause for the, optionally api-dependent, named type
  (string-append (bad-argument-clause argnam) " - " (type-name-clause typnam)) )

(define (interval-name lft min max rgt)
  (string-append (->string lft) (->string min) " " (->string max) (->string rgt)) )

(define (make-error-interval-message lft min max rgt #!optional argnam)
  (string-append (make-bad-argument-message argnam)
                 " must be in "
                 (interval-name lft min max rgt)) )

(define (location-clause loc)
  (if (not loc)
      ""
      (string-append (make-location-message loc) " ")) )

(define (typed-object-error-clause obj typnam #!optional argnam)
  (string-append (make-error-type-message typnam argnam) ": " (->string obj)) )

(define (make-warning-type-message loc obj typnam #!optional argnam)
  (string-append (location-clause loc) (typed-object-error-clause obj typnam argnam)) )