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

(module type-errors-basic

(;export
  ;
  make-location-message
  make-bad-argument-message
  make-type-name-message
  make-tagged-kind-message
  ;
  make-error-type-message
  make-error-interval-message
  make-warning-type-message
  make-arity-low-message
  make-arity-message
  ;
  signal-bounds-error signal-type-error signal-arity-error
  ;
  error-argument-type
  warning-argument-type
  ;
  error-bound-value
  error-defined-value
  ;
  error-minimum-argument-count
  error-argument-count
  ;
  define-error-type)

(import scheme)
(import (chicken base))
(import (chicken type))
(import (only (chicken string) ->string) (only (chicken format) format))

;message api

(: make-location-message (* --> string))
(: make-bad-argument-message (#!optional * --> string))
(: make-type-name-message (* --> string))
(: make-tagged-kind-message (* * --> string))
(: make-error-type-message (* #!optional * --> string))
(: make-error-interval-message (* * * * #!optional * --> string))
(: make-warning-type-message (* * * #!optional * --> string))
(: make-arity-low-message (fixnum fixnum --> string))
(: make-arity-message (fixnum fixnum --> string))

;;

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

;; Locale Specific API

(cond-expand
  (else ;default `en'
    (include-relative "type-errors-en.incl") ) )

;;

(define-syntax warning-argument-type
  (syntax-rules ()
    ((_ ?loc ?obj ?typnam)
      (warning-argument-type ?loc ?obj ?typnam #f) )
    ((_ ?loc ?obj ?typnam ?argnam)
      (warning (make-warning-type-message ?loc ?obj ?typnam ?argnam)) ) ) )

;

(define-syntax signal-bounds-error
  (syntax-rules ()
    ((_ ?loc ?objs ...)
      (##sys#signal-hook #:bounds-error ?loc ?objs ...) ) ) )

(define-syntax signal-type-error
  (syntax-rules ()
    ((_ ?loc ?objs ...)
      (##sys#signal-hook #:type-error ?loc ?objs ...) ) ) )

(define-syntax signal-arity-error
  (syntax-rules ()
    ((_ ?loc ?objs ...)
      (##sys#signal-hook #:arity-error ?loc ?objs ...) ) ) )

;

(define-syntax error-argument-type
  (syntax-rules ()
    ((_ ?loc ?obj ?typnam)
      (error-argument-type ?loc ?obj ?typnam #f) )
    ((_ ?loc ?obj ?typnam ?argnam)
      (signal-type-error ?loc (make-error-type-message ?typnam ?argnam) ?obj) ) ) )

;

(define-syntax error-bound-value
  (syntax-rules ()
    ((_ ?loc ?obj)
      (error-bound-value ?loc ?obj #f) )
    ((_ ?loc ?obj ?argnam)
      (error-argument-type ?loc "#<unbound>" "bound-value" ?argnam) ) ) )

(define-syntax error-defined-value
  (syntax-rules ()
    ((_ ?loc ?obj)
      (error-defined-value ?loc ?obj #f) )
    ((_ ?loc ?obj ?argnam)
      (error-argument-type ?loc "#<unspecified>" "defined-value" ?argnam) ) ) )

;

;nothing to add to the error message, so builtin direct

(define-syntax error-argument-count
  (syntax-rules ()
    ((_ ?loc ?argc ?maxargc)
      (signal-arity-error ?loc (make-arity-message ?argc ?maxargc)) ) ) )

(define-syntax error-minimum-argument-count
  (syntax-rules ()
    ((_ ?loc ?argc ?minargc)
      (signal-arity-error ?loc (make-arity-low-message ?argc ?minargc)) ) ) )

;

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

) ;module type-errors-basic