#| 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 is-type? (condition-predicate 'type))

(define (create-predicate id)
  (lambda (proc)
    (cond
      ((not (procedure? proc)) #f)
      ((get-mapping proc)
       => (cut fxmapping-contains? <> id))
      (else #f))))

(define (create-accessor id)
  (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))))

;;; ;;;;;;;;;;;;;;;
;;; Bootstrapping
;;; ;;;;;;;;;;;;;;;

(define get-base-procedure (create-accessor 0))
(define tagged-procedure? (create-predicate 0))

(define procedure/self-tag -1)
(define procedure/self? (create-predicate procedure/self-tag))

(define (create-constructor id)
  (lambda (tag proc)
    (cond
      ((not (procedure? proc))
       (abort (make-composite-condition
               (make-property-condition
                'exn
                'location
                (quote constructor)
                'arguments
                (list proc)
                'message
                "not a procedure")
               (make-property-condition
                'type
                'value
                proc))))
      ((procedure/self? proc)
       (letrec* ((base (get-base-procedure proc))
                 (nproc
                  (create/signifier-pair (lambda args
                                           (apply base nproc args))
                                         (make-signifier
                                          (fxmapping-set (get-mapping proc)
                                                         id
                                                         tag)))))
         nproc))
      ((tagged-procedure? proc)
       (let ((map (get-mapping proc)))
         (set-signifier-pair proc
                             unique-symbol
                             (make-signifier
                              (fxmapping-set map id tag)))))
      (else (create/signifier-pair proc
                                   (make-signifier
                                    (fxmapping id tag
                                               0 proc)))))))

(define tag/this (create-constructor -1))

(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
          (create-constructor id)
          (create-predicate id)
          (create-accessor id)))))))

(define-syntax lambda/this
  (syntax-rules ()
    ((lambda/this this formal body ...)
     ;; Quick hack to make the constructor work. Should fix.
     (tag/this #f
               (tag/this #f
                         (lambda (this . formal) body ...))))))

(define-syntax define/this
  (syntax-rules ()
    ((define/this (name this . args) body ...)
     (define name (lambda/this this args body ...)))))