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

;; 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", ...

;;

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

;;

;locale message api

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

(define (1st-letter s) (string-ref s 0))

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

;

(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") ) )

;;

;locale message api

(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)) )

;;

;locale message api

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

(define (error-interval-clause lft min max rgt)
  (string-append " must be in " (interval-name lft min max rgt)) )

;

(define (make-error-interval-message lft min max rgt #!optional argnam)
  (string-append (make-bad-argument-message argnam) (error-interval-clause lft min max rgt)) )

;;

;locale message api

(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)) )

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

;;

(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) )

;;

; <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 #!optional argnam)
  (error-argument-type loc "#<unbound>" "bound-value" argnam) )

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

(define (error-minimum-argument-count loc argc minargc)
  (##sys#signal-hook #:arity-error loc
    (string-append "too few arguments - received "
                   (number->string argc)
                   " but expected "
                   (number->string 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
    (string-append "bad argument count - received "
                   (number->string argc)
                   " but expected "
                   (number->string maxargc)))
  #; ;int & foreign-value unrecognized, & foreign is imported
  (##sys#error-hook
    (foreign-value "C_BAD_ARGUMENT_COUNT_ERROR" int)
    loc
    maxargc argc #f) )