#lang racket/base
(require "../host/rktio.rkt"
         "../print/parameter.rkt"
         "../port/string-port.rkt"
         (submod "../print/main.rkt" internal)
         "../format/printf.rkt"
         "../string/convert.rkt"
         "value-string.rkt")

(provide error
         raise-user-error
         error-print-source-location
         exn-classify-errno)

(define (error init . args)
  (raise
   (format-error 'error exn:fail init args)))

(define (raise-user-error init . args)
  (raise
   (format-error 'raise-user-error exn:fail:user init args)))

(define (format-error who exn:fail init args)
  (cond
   [(and (symbol? init)
         (null? args))
    (exn:fail
     (string-append "error: " (symbol->string init))
     (current-continuation-marks))]
   [(symbol? init)
    (unless (string? (car args))
      (raise-argument-error who "string?" (car args)))
    (define o (open-output-string))
    (do-printf who o (car args) (cdr args))
    (exn:fail
     (string-append (symbol->string init)
                    ": "
                    (get-output-string o))
     (current-continuation-marks))]
   [(string? init)
    (exn:fail
     (apply string-append
            init
            (for/list ([arg (in-list args)])
              (string-append " "
                             ((error-value->string-handler)
                              arg
                              (error-print-width)))))
     (current-continuation-marks))]
   [else
    (raise-argument-error who "(or/c symbol? string?)" init)]))

(define error-print-source-location
  (make-parameter #t (lambda (v) (and v #t)) 'error-print-source-location))

(define (default-error-value->string-handler v len)
  (unless (exact-nonnegative-integer? len)
    (raise-argument-error 'default-error-value->string-handler
                          "exact-nonnegative-integer?"
                          len))
  (define o (open-output-string))
  (do-global-print 'default-error-value->string-handler v o 0 len)
  (get-output-string o))

(define (default-error-module-path->string-handler v len)
  (unless (exact-nonnegative-integer? len)
    (raise-argument-error 'default-error-module-path->string-handler
                          "exact-nonnegative-integer?"
                          len))
  (define o (open-output-string))
  (do-write 'default-error-value->string-handler v o len)
  (get-output-string o))

(define (exn-classify-errno errno/exn)
  (unless (or (exn? errno/exn)
              (and (pair? errno/exn)
                   (exact-integer? (car errno/exn))
                   (memq (cdr errno/exn) '(posix windows gai))))
    (raise-argument-error 'exn-classify-errno
                          "(or/c exn? (cons/c exact-integer? (or/c 'posix 'windows 'gai)))"
                          errno/exn))
  (cond
    [(exn:fail:filesystem:exists? errno/exn)
     'EEXIST]
    [else
     (define errno
       (cond
         [(pair? errno/exn) errno/exn]
         [(exn:fail:filesystem:errno? errno/exn)
          (exn:fail:filesystem:errno-errno errno/exn)]
         [(exn:fail:network:errno? errno/exn)
          (exn:fail:network:errno-errno errno/exn)]
         [else '(#f . #f)]))
     (and (fixnum? (car errno))
          (let ([bstr (rktio_classify_error (case (cdr errno)
                                              [(posix) RKTIO_ERROR_KIND_POSIX]
                                              [(windows) RKTIO_ERROR_KIND_WINDOWS]
                                              [else RKTIO_ERROR_KIND_GAI])
                                            (car errno))])
            (and bstr
                 (string->symbol (bytes->string/latin-1 bstr)))))]))

;; Install the default error-value->string handler,
;; replacing the non-working primitive placeholder
(define (install-error-value->string-handler!)
  (error-value->string-handler default-error-value->string-handler)
  (register-error-value->string!
   (lambda (v)
     (define len (error-print-width))
     (define h (error-value->string-handler))
     (define result
       (parameterize ([error-value->string-handler default-error-value->string-handler]
                      [print-unreadable #t])
         (h v len)))
     (define str
       (cond
         [(string? result) result]
         [(bytes? result) (bytes->string/utf-8 result #\?)]
         [else "..."]))
     (if ((string-length str) . > . len)
         (substring str 0 len)
         str)))
  (error-module-path->string-handler default-error-module-path->string-handler))

(void (install-error-value->string-handler!))

(module+ place-init
  (provide install-error-value->string-handler!))
