;;;; Copyright (C) 2025 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

(define-module (ice-9 deprecated)
  #:use-module (ice-9 hooks)
  #:use-module (ice-9 guardians)
  #:use-module (ice-9 object-properties)
  #:use-module (ice-9 source-properties)
  #:use-module (ice-9 weak-tables)
  #:use-module (ice-9 arrays)
  #:use-module (ice-9 scm-style-repl)
  #:use-module (ice-9 promises)
  #:use-module (system repl hooks)
  #:use-module (system repl reader)
  #:use-module (srfi srfi-14)
  #:export ((make-guardian* . make-guardian)
            module-observe-weak
            (make-object-property* . make-object-property)
            (make-weak-key-hash-table* . make-weak-key-hash-table)
            (make-weak-value-hash-table* . make-weak-value-hash-table)
            (make-doubly-weak-hash-table* . make-doubly-weak-hash-table)
            (weak-key-hash-table?* . weak-key-hash-table?)
            (weak-value-hash-table?* . weak-value-hash-table?)
            (doubly-weak-hash-table?* . doubly-weak-hash-table?)
            (supports-source-properties?* . supports-source-properties?)
            (source-properties* . source-properties)
            (set-source-properties!* . set-source-properties!)
            (source-property* . source-property)
            (set-source-properties* . set-source-property!)
            (cons-source* . cons-source)
            (array-fill!* . array-fill!)
            (array-copy!* . array-copy!)
            (array-copy-in-order!* . array-copy-in-order!)
            (array-map!* . array-map!)
            (array-for-each* . array-for-each)
            (array-index-map!* . array-index-map!)
            (array-equal?* . array-equal?)
            (array-slice-for-each* . array-slice-for-each)
            (array-slice-for-each-in-order* . array-slice-for-each-in-order)
            (char-set?* . char-set?)
            (char-set=* . char-set=)
            (char-set<=* . char-set<=)
            (char-set-hash* . char-set-hash)
            (char-set-cursor* . char-set-cursor)
            (char-set-ref* . char-set-ref)
            (char-set-cursor-next* . char-set-cursor-next)
            (end-of-char-set?* . end-of-char-set?)
            (char-set-fold* . char-set-fold)
            (char-set-unfold* . char-set-unfold) char-set-unfold!
            (char-set-for-each* . char-set-for-each)
            (char-set-map* . char-set-map)
            (char-set-copy* . char-set-copy)
            (char-set* . char-set)
            (list->char-set* . list->char-set)
            (list->char-set!* . list->char-set!)
            (string->char-set* . string->char-set)
            (string->char-set!* . string->char-set!)
            (char-set-filter* . char-set-filter)
            (char-set-filter!* . char-set-filter!)
            (ucs-range->char-set* . ucs-range->char-set)
            (ucs-range->char-set!* . ucs-range->char-set!)
            (->char-set* . ->char-set)
            (char-set-size* . char-set-size)
            (char-set-count* . char-set-count)
            (char-set->list* . char-set->list)
            (char-set->string* . char-set->string)
            (char-set-contains?* . char-set-contains?)
            (char-set-every* . char-set-every)
            (char-set-any* . char-set-any)
            (char-set-adjoin* . char-set-adjoin)
            (char-set-adjoin!* . char-set-adjoin!)
            (char-set-delete* . char-set-delete)
            (char-set-delete!* . char-set-delete!)
            (char-set-complement* . char-set-complement)
            (char-set-union* . char-set-union)
            (char-set-intersection* . char-set-intersection)
            (char-set-difference* . char-set-difference)
            (char-set-xor* . char-set-xor)
            (char-set-diff+intersection* . char-set-diff+intersection)
            (char-set-complement!* . char-set-complement!)
            (char-set-union!* . char-set-union!)
            (char-set-intersection!* . char-set-intersection!)
            (char-set-difference!* . char-set-difference!)
            (char-set-xor!* . char-set-xor!)
            (char-set-diff+intersection!* . char-set-diff+intersection!)
            (char-set:lower-case* . char-set:lower-case)
            (char-set:upper-case* . char-set:upper-case)
            (char-set:title-case* . char-set:title-case)
            (char-set:letter* . char-set:letter)
            (char-set:digit* . char-set:digit)
            (char-set:letter+digit* . char-set:letter+digit)
            (char-set:graphic* . char-set:graphic)
            (char-set:printing* . char-set:printing)
            (char-set:whitespace* . char-set:whitespace)
            (char-set:iso-control* . char-set:iso-control)
            (char-set:punctuation* . char-set:punctuation)
            (char-set:symbol* . char-set:symbol)
            (char-set:hex-digit* . char-set:hex-digit)
            (char-set:blank* . char-set:blank)
            (char-set:ascii* . char-set:ascii)
            (char-set:empty* . char-set:empty)
            (char-set:full* . char-set:full)
            (abort-hook* . abort-hook)
            (before-backtrace-hook* . before-backtrace-hook)
            (after-backtrace-hook* . after-backtrace-hook)
            (before-error-hook* . before-error-hook)
            (after-error-hook* . after-error-hook)
            (before-read-hook* . before-read-hook)
            (after-read-hook* . after-read-hook)
            (before-eval-hook* . before-eval-hook)
            (after-eval-hook* . after-eval-hook)
            (before-print-hook* . before-print-hook)
            (after-print-hook* . after-print-hook)
            (exit-hook* . exit-hook)
            (repl-reader* . repl-reader)
            (make-hook* . make-hook)
            (hook?* . hook?)
            (hook-empty?* . hook-empty?)
            (add-hook!* . add-hook!)
            (remove-hook!* . remove-hook!)
            (reset-hook!* . reset-hook!)
            (run-hook* . run-hook)
            (hook->list* . hook->list)
            module-defined-hook
            (make-promise* . make-promise)
            (promise? . promise?)
            (delay* . delay)
            (force* . force)))

(define-syntax define-deprecated/stx
  (lambda (stx)
    (syntax-case stx ()
      ((_ mod id)
       (let* ((id* (datum->syntax #'id
                                  (symbol-append (syntax->datum #'id) '*)))
              (msg (string-append
                    (symbol->string (syntax->datum #'id))
                    " in the default environment is deprecated.\n"
                    "Import it from " (object->string (syntax->datum #'mod))
                    " instead.")))
         #`(define-syntax #,id*
             (identifier-syntax
              (begin
                (issue-deprecation-warning #,msg)
                #,#'id))))))))

(define-syntax define-deprecated-trampoline
  (lambda (stx)
    (syntax-case stx ()
      ((_ ((mod proc) . params) exp)
       (let* ((proc* (datum->syntax #'proc
                                    (symbol-append (syntax->datum #'proc) '*)))
              (msg (string-append
                    (symbol->string (syntax->datum #'proc))
                    " in the default environment is deprecated.\n"
                    "Import it from " (object->string (syntax->datum #'mod))
                    " instead.")))
         #`(define* (#,proc* . params)
             (issue-deprecation-warning #,msg)
             exp))))))

(define-syntax define-deprecated-trampolines
  (lambda (stx)
    (syntax-case stx ()
      ((_ mod (proc arg ...) ...)
       #'(begin
           (define-deprecated-trampoline ((mod proc) arg ...)
             (proc arg ...))
           ...)))))

(define-deprecated-trampolines (ice-9 guardians)
  (make-guardian))

(define* (module-observe-weak module observer-id #:optional (proc observer-id))
  (issue-deprecation-warning
   "module-observe-weak is deprecated.  Use module-observe instead.")
  (module-observe module proc))

(define-deprecated-trampolines (ice-9 object-properties)
  (make-object-property)
  (object-properties obj)
  (set-object-properties! obj props)
  (object-property obj key)
  (set-object-property! obj key value))

(define-deprecated-trampoline (((ice-9 weak-tables) make-weak-key-hash-table)
                               #:optional (n 0))
  (make-weak-key-hash-table))
(define-deprecated-trampoline (((ice-9 weak-tables) make-weak-value-hash-table)
                               #:optional (n 0))
  (make-weak-value-hash-table))
(define-deprecated-trampoline (((ice-9 weak-tables) make-doubly-weak-hash-table)
                               #:optional (n 0))
  (make-doubly-weak-hash-table))

(define-deprecated-trampolines (ice-9 weak-tables)
  (weak-key-hash-table? x)
  (weak-value-hash-table? x)
  (doubly-weak-hash-table? x))

(define-deprecated-trampolines (ice-9 source-properties)
  (supports-source-properties? x)
  (source-properties x)
  (set-source-properties! x alist)
  (source-property x k)
  (set-source-property! x k v)
  (cons-source orig x y))

(define-deprecated-trampolines (ice-9 arrays)
  (array-fill! array fill)
  (array-copy! src dst)
  (array-copy-in-order! src dst)
  (array-index-map! array proc))

(define-deprecated-trampoline (((ice-9 arrays) array-map!) dst proc . src*)
  (apply array-map! dst proc src*))
(define-deprecated-trampoline (((ice-9 arrays) array-for-each) proc array . arrays)
  (apply array-for-each proc array arrays))
(define-deprecated-trampoline (((ice-9 arrays) array-equal?) . arrays)
  (apply array-equal? arrays))
(define-deprecated-trampoline (((ice-9 arrays) array-slice-for-each) frame-rank proc . arrays)
  (apply array-slice-for-each frame-rank proc arrays))
(define-deprecated-trampoline (((ice-9 arrays) array-slice-for-each-in-order) frame-rank proc . arrays)
  (apply array-slice-for-each-in-order frame-rank proc arrays))
(define-deprecated-trampoline (((ice-9 arrays) array-cell-ref) array . indices)
  (apply array-cell-ref array indices))
(define-deprecated-trampoline (((ice-9 arrays) array-cell-set!) array val . indices)
  (apply array-cell-set! array val indices))

(define-deprecated-trampolines (ice-9 arrays)
  (array-fill! array fill)
  (array-copy! src dst)
  (array-copy-in-order! src dst)
  (array-index-map! array proc))

(define-deprecated-trampoline (((srfi srfi-14) char-set=) . char-sets)
  (apply char-set= char-sets))
(define-deprecated-trampoline (((srfi srfi-14) char-set-hash) cs #:optional (bound 871))
  (char-set-hash cs bound))
(define-deprecated-trampoline (((srfi srfi-14) char-set-unfold) p f g seed #:optional (base-cs (char-set)))
  (char-set-unfold p f g seed base-cs))
(define-deprecated-trampoline (((srfi srfi-14) char-set) . chars)
  (list->char-set chars))
(define-deprecated-trampoline (((srfi srfi-14) list->char-set) list #:optional (base-cs (char-set)))
  (list->char-set list base-cs))
(define-deprecated-trampoline (((srfi srfi-14) string->char-set) string #:optional (base-cs (char-set)))
  (string->char-set string base-cs))
(define-deprecated-trampoline (((srfi srfi-14) char-set-filter) pred cs #:optional (base-cs (char-set)))
  (char-set-filter pred cs base-cs))
(define-deprecated-trampoline (((srfi srfi-14) ucs-range->char-set) lower upper
                               #:optional error (base-cs (char-set)))
  (ucs-range->char-set lower upper error base-cs))
(define-deprecated-trampoline (((srfi srfi-14) char-set-adjoin) cs . rest)
  (apply char-set-adjoin cs rest))
(define-deprecated-trampoline (((srfi srfi-14) char-set-delete) cs . rest)
  (apply char-set-delete cs rest))
(define-deprecated-trampoline (((srfi srfi-14) char-set-adjoin!) cs . rest)
  (apply char-set-adjoin! cs rest))
(define-deprecated-trampoline (((srfi srfi-14) char-set-delete!) cs . rest)
  (apply char-set-delete! cs rest))
(define-deprecated-trampoline (((srfi srfi-14) char-set-union) . rest)
  (apply char-set-union rest))
(define-deprecated-trampoline (((srfi srfi-14) char-set-intersection) . rest)
  (apply char-set-intersection rest))
(define-deprecated-trampoline (((srfi srfi-14) char-set-difference) cs . rest)
  (apply char-set-difference cs rest))
(define-deprecated-trampoline (((srfi srfi-14) char-set-xor) . rest)
  (apply char-set-xor rest))
(define-deprecated-trampoline (((srfi srfi-14) char-set-diff+intersection) cs . rest)
  (apply char-set-diff+intersection cs rest))
(define-deprecated-trampoline (((srfi srfi-14) char-set-union!) . rest)
  (apply char-set-union! rest))
(define-deprecated-trampoline (((srfi srfi-14) char-set-intersection!) . rest)
  (apply char-set-intersection! rest))
(define-deprecated-trampoline (((srfi srfi-14) char-set-difference!) cs . rest)
  (apply char-set-difference! cs rest))
(define-deprecated-trampoline (((srfi srfi-14) char-set-xor!) . rest)
  (apply char-set-xor! rest))
(define-deprecated-trampoline (((srfi srfi-14) char-set-diff+intersection!) cs . rest)
  (apply char-set-diff+intersection! cs rest))
(define-deprecated-trampolines (srfi srfi-14)
  (char-set? x)
  (char-set-cursor cs)
  (char-set-ref cs cursor)
  (char-set-cursor-next cs cursor)
  (end-of-char-set? cursor)
  (char-set-fold kons knil cs)
  (char-set-unfold! p f g seed base-cs)
  (char-set-for-each proc cs)
  (char-set-map proc cs)
  (char-set-copy cs)
  (list->char-set! list base-cs)
  (string->char-set! str base-cs)
  (char-set-filter! pred cs base-cs)
  (ucs-range->char-set! lower upper error base-cs)
  (->char-set x)
  (char-set-size cs)
  (char-set-count pred cs)
  (char-set->list cs)
  (char-set->string cs)
  (char-set-contains? cs ch)
  (char-set-every pred cs)
  (char-set-complement cs))

(define-syntax-rule (define-deprecated*/stx mod id ...)
  (begin
    (define-deprecated/stx mod id)
    ...))
(define-deprecated*/stx (srfi srfi-14)
  ;; Standard character sets
  char-set:lower-case
  char-set:upper-case
  char-set:title-case
  char-set:letter
  char-set:digit
  char-set:letter+digit
  char-set:graphic
  char-set:printing
  char-set:whitespace
  char-set:iso-control
  char-set:punctuation
  char-set:symbol
  char-set:hex-digit
  char-set:blank
  char-set:ascii
  char-set:empty
  char-set:full)

(define-deprecated*/stx (system repl hooks)
  before-error-hook
  after-error-hook
  before-read-hook
  after-read-hook
  before-eval-hook
  after-eval-hook
  before-print-hook
  after-print-hook
  exit-hook)

(define-deprecated*/stx (system repl reader)
  repl-reader)

(define-deprecated*/stx (ice-9 scm-style-repl)
  abort-hook
  before-backtrace-hook
  after-backtrace-hook)

(define-deprecated-trampoline (((ice-9 hooks) make-hook) #:optional arity)
  (make-hook))
(define-deprecated-trampoline (((ice-9 hooks) add-hook!) hook f #:optional append?)
  (add-hook! hook f #:append? append?))
(define-deprecated-trampoline (((ice-9 hooks) run-hook) hook . args)
  (apply run-hook hook args))

(define-deprecated-trampolines (ice-9 hooks)
  (hook? x)
  (hook-empty? hook)
  (remove-hook! hook proc)
  (reset-hook! hook)
  (hook->list hook))

(define module-defined-hook (make-hook 1))
(let ((prev (module-definition-observer)))
  (module-definition-observer
   (lambda (m)
     (run-hook module-defined-hook m)
     (prev m))))

(define-deprecated-trampolines (ice-9 promises)
  (promise? x)
  (make-promise thunk)
  (force promise))
(define-deprecated*/stx (ice-9 promises) delay)

(cond-expand
 ;; FIXME: Don't include this if there is no regexp support!
 ((or regex guile)
  (use-modules (ice-9 regex))

  (define-deprecated-trampoline (((ice-9 regex) make-regexp) pat . flags)
    (apply make-regexp pat flags))
  (define-deprecated-trampoline (((ice-9 regex) regexp?) x)
    (regexp? x))
  (define-deprecated-trampoline (((ice-9 regex) regexp-exec) rx str #:optional (start 0) (flags 0))
    (regexp-exec rx str start flags))
  (define-deprecated*/stx (ice-9 regex)
    regexp/basic
    regexp/extended
    regexp/icase
    regexp/newline
    regexp/notbol
    regexp/noteol)

  (export (make-regexp* . make-regexp)
          (regexp?* . regexp?)
          (regexp-exec* . regexp-exec)
          (regexp/basic* . regexp/basic)
          (regexp/extended* . regexp/extended)
          (regexp/icase* . regexp/icase)
          (regexp/newline* . regexp/newline)
          (regexp/notbol* . regexp/notbol)
          (regexp/noteol* . regexp/noteol)))
 (else))