#| Copyright (C) 2025 Peter McGoron
 |
 | Permission is hereby granted, free of charge, to any person obtaining a
 | copy of this software and associated documentation files (the
 | "Software"), to deal in the Software without restriction, including
 | without limitation the rights to use, copy, modify, merge, publish,
 | distribute, sublicense, and/or sell copies of the Software, and to
 | permit persons to whom the Software is furnished to do so, subject to
 | the following conditions:
 |
 | The above copyright notice and this permission notice (including the
 | next paragraph) shall be included in all copies or substantial portions
 | of the Software.
 |
 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 |#

(define-library (srfi 259)
  (import (scheme base) (scheme write)
          integer-map
          (chicken base)
          (chicken foreign)
          (chicken condition)
          (chicken fixnum))
  (export define-procedure-tag)
  (include "lowlevel.scm")
  (begin
    (define is-type? (condition-predicate 'type))
    (define-syntax define-procedure-tag
      (syntax-rules ()
        ((define-procedure-tag constructor predicate? accessor)
         ;; This uses `define-values` instead of a define for `id` because
         ;; Chicken breaks hygiene for top-level `define` names.
         (define-values (constructor predicate? accessor)
           (let ((id (unique-id)))
             (values
              ;; constructor
              (lambda (tag proc)
                (handle-exceptions E (abort
                                      (make-composite-condition
                                       (make-property-condition
                                        'exn
                                        'location
                                        (quote constructor)
                                        'arguments
                                        (list proc)
                                        'message
                                        "not a procedure")
                                       E))
                  (set-tagged-mapping proc id tag)))
              ;; predicate?
              (lambda (proc)
                (cond
                  ((not (procedure? proc)) #f)
                  ((get-mapping proc)
                   => (cut fxmapping-contains? <> id))
                  (else #f)))
              ;; accessor
              (lambda (proc)
                (define map
                  (handle-exceptions E (abort
                                        (make-composite-condition
                                         (make-property-condition
                                          'exn
                                          'location
                                          (quote accessor)
                                          'arguments
                                          (list proc)
                                          'message
                                          "not a procedure")
                                         E))
                    (get-mapping proc)))
                (define (raise-error)
                  (abort
                   (make-composite-condition
                    (make-property-condition 'exn
                                             'location
                                             (quote accessor)
                                             'arguments
                                             (list proc)
                                             'message
                                             "tag was not found")
                    (make-property-condition 'assertion))))
                (if map
                    (fxmapping-ref map id raise-error)
                    (raise-error)))))))))))