;;;; type-errors-basic.impl.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18

;; Issues
;;
;; - The type error message is built so as to look like those of the Chicken
;; "core". This constraint necessarily means some knowledge of the use of the
;; indefinite article. So any I18N effort will either have some logic needed or
;; a change to the Chicken "core" form.
;;
;; Maybe "... not an integer" -> "... integer required" &
;; "... not a list" -> "... list required".

(import scheme
  (only (chicken string) ->string conc)
  (chicken foreign)
  (chicken type))

;;;

;;

(define (->boolean x)
  (and x #t) )

;;;

;;

(define (make-bad-argument-message #!optional argnam)
  (if (not argnam)
    "bad argument"
    (conc "bad " #\` argnam #\' " argument") ) )

(define (make-type-name-message typnam)
  (or
    (localized-type-name-message typnam)
    (->string typnam)) )

(define (make-error-type-message typnam #!optional argnam)
  (string-append
    (make-bad-argument-message argnam)
    " type - not "
    (make-type-name-message typnam)) )

;;

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

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

;;

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

;;

(define (warning-argument-type loc obj typnam #!optional argnam)
  (let* (
    (typmsg (make-error-type-message typnam argnam))
    (locmsg (if loc (string-append (location-message loc) " ") ""))
    (wrn-msg (conc locmsg typmsg ": " obj)) )
    (warning wrn-msg) ) )

(define (location-message loc)
  (conc #\( loc #\)) )

;;

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

(define-syntax define-error-type
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (let (
        (_define (rnm 'define))
        (_#!optional (rnm '#!optional))
        (_error-argument-type (rnm 'error-argument-type)) )
        (let* (
          (typ (cadr frm))
          (typstr (symbol->string typ))
          (typnam (if (null? (cddr frm)) typstr (caddr frm)))
          (nam (string->symbol (string-append "error-" typstr))) )
          `(,_define (,nam loc obj ,_#!optional argnam)
             (,_error-argument-type loc obj ,typnam argnam) ) ) ) ) ) )

;;

(define (error-bound-value loc obj tag #!optional argnam)
	(error-argument-type loc "#<unbound>" "bound-value" argnam) )

(define (error-defined-value loc obj tag #!optional argnam)
	(error-argument-type loc "#<unspecified>" "defined-value" argnam) )

(define (error-minimum-argument-count loc argc minargc)
  (##sys#signal-hook #:arity-error loc
    (conc "too few arguments - received " argc " but expected " minargc))
  #; ;int & foreign-value unrecognized, & foreign is imported
  (##sys#error-hook
    (foreign-value "C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR" int)
    loc
    minargc argc #f) )

(define (error-argument-count loc argc maxargc)
  (##sys#signal-hook #:arity-error loc
    (conc "bad argument count - received " argc " but expected " maxargc))
  #; ;int & foreign-value unrecognized, & foreign is imported
  (##sys#error-hook
    (foreign-value "C_BAD_ARGUMENT_COUNT_ERROR" int)
    loc
    maxargc argc #f) )

;;;

;;

(define (localized-type-name-message typnam)
  ;FIXME en only
  (conc (appropriate-indefinite-article typnam) " " typnam) )

;;

(define +english-vowels+ '(#\a #\e #\i #\o #\u))
(define +english-indefinite-articles+ '(an a))

(define (vowel? ch)
  (->boolean (memq ch +english-vowels+)) )

(define (appropriate-indefinite-article wrd)
  (let ((s (->string wrd)))
    (if (vowel? (string-ref s 0))
      (car +english-indefinite-articles+)
      (cadr +english-indefinite-articles+) ) ) )