;;;; SPDX-FileCopyrightText: 2016 Vasilij Schneidermann <mail@vasilij.de>
;;;; SPDX-FileCopyrightText: 2021 Evan Hanson <evhan@foldling.org>
;;;;
;;;; SPDX-License-Identifier: GPL-3.0-or-later

(declare
  (emit-external-prototypes-first))

#>
#include "readline/readline.h"
#include "readline/history.h"
<#

;;; history

(define (history-length) (foreign-value "history_length" int))

(define history-file (make-parameter #f))

(define add-history!
  (foreign-lambda void "add_history" (const nonnull-c-string)))

(define strerror (foreign-lambda c-string "strerror" int))

(define (history-error errno location)
  (condition `(exn location ,location message ,(strerror errno)) '(i/o) '(file)))

(define (read-history! filename)
  (let ((ret ((foreign-lambda int "read_history" (const c-string)) filename)))
    (when (not (zero? ret))
      (abort (history-error ret 'read-history!)))))

(define (write-history! filename)
  (let ((ret ((foreign-lambda int "write_history" (const c-string)) filename)))
    (when (not (zero? ret))
      (abort (history-error ret 'write-history!)))))

(define stifle-history!
  (foreign-lambda void "stifle_history" int))

(define unstifle-history!
  (foreign-lambda int "unstifle_history"))

;;; completion

#>
void *readline_completer_proc;

char *copy_scheme_string(C_word string) {
  char *src = C_c_string(string);
  size_t size = C_unfix(C_i_string_length(string));
  char *dest = malloc(size + 1);
  if (dest == NULL) {
    return NULL;
  }
  strncpy(dest, src, size);
  dest[size] = '\0';
  return dest;
}

char *readline_completer(const char *prefix, int state) {
  C_word completer = CHICKEN_gc_root_ref(readline_completer_proc);
  int size = C_SIZEOF_STRING(strlen(prefix));
  C_word *a = C_alloc(size);
  C_callback_adjust_stack(a, size);
  C_save(C_fix(state));
  C_save(C_string2(&a, (char *) prefix));
  C_word result = C_callback(completer, 2);
  if (result == C_SCHEME_FALSE) {
    return NULL;
  } else {
    return copy_scheme_string(result);
  }
}
<#

(foreign-code
 "readline_completer_proc = CHICKEN_new_gc_root();"
 "rl_completion_entry_function = &readline_completer;")

(define (completer-set! proc)
  (when (not (procedure? proc))
    (error "bad argument type - not a procedure" proc))
  ((foreign-lambda* void ((scheme-object completer))
     "CHICKEN_gc_root_set(readline_completer_proc, completer);")
   proc))

;; HACK: readline's default completion uses file names from the
;; current directory, to disable it one can either bind TAB to a
;; different action or use a custom completion function constantly
;; returning NULL...

(define (dummy-completer _state _prefix) #f)
(completer-set! dummy-completer)

(define (completer-word-break-characters-set! string)
  (when (not (string? string))
    (error "bad argument type - not a string" string))
  ((foreign-lambda* void ((scheme-object string))
     ;; NOTE: the result is never freed which one might want if this
     ;; procedure were to be called more than once...
     "char *chars = copy_scheme_string(string);"
     "if (chars) rl_completer_word_break_characters = chars;")
   string))

;;; misc

(define (line-buffer) (foreign-value "rl_line_buffer" c-string))
(define (point) (foreign-value "rl_point" int))
(define (end) (foreign-value "rl_end" int))

(define (display-prompt) (foreign-value "rl_display_prompt" c-string))

(define variable-bind!
  ;; NOTE: this seems to always return zero
  (foreign-lambda int "rl_variable_bind" (const nonnull-c-string) (const nonnull-c-string)))

(define variable-value
  (foreign-lambda c-string "rl_variable_value" (const nonnull-c-string)))

(define (basic-quote-characters-set! string)
  (when (not (string? string))
    (error "bad argument type - not a string" string))
  ((foreign-lambda* void ((scheme-object string))
     "char *chars = copy_scheme_string(string);"
     "if (chars) rl_basic_quote_characters = chars;")
   string))

(define paren-blink-timeout-set!
  (foreign-lambda int "rl_set_paren_blink_timeout" int))

(define insert-text
  (foreign-lambda int "rl_insert_text" (const nonnull-c-string)))

(define delete-text
  (foreign-lambda int "rl_delete_text" int int))

(define stuff-char
  (foreign-lambda int "rl_stuff_char" char))

(define redisplay
  (foreign-lambda void "rl_redisplay"))

(define cleanup-after-signal!
  (foreign-lambda void "rl_cleanup_after_signal"))

(define reset-after-signal!
  (foreign-lambda void "rl_reset_after_signal"))

(define (reset-terminal! #!optional terminal-name)
  ((foreign-lambda bool "rl_reset_terminal" c-string) terminal-name))

;;; Events

#>

void *readline_event_hook_proc;
void *readline_pre_input_hook_proc;
void *readline_redisplay_function_proc;

<#

(foreign-code
 ;; rl_event_hook
 "readline_event_hook_proc = CHICKEN_new_gc_root();"
 "CHICKEN_gc_root_set(readline_event_hook_proc, C_SCHEME_FALSE);"
 ;; rl_pre_input_hook
 "readline_pre_input_hook_proc = CHICKEN_new_gc_root();"
 "CHICKEN_gc_root_set(readline_pre_input_hook_proc, C_SCHEME_FALSE);"
 ;; rl_redisplay_function
 "readline_redisplay_function_proc = CHICKEN_new_gc_root();"
 "CHICKEN_gc_root_set(readline_redisplay_function_proc, C_SCHEME_FALSE);")

(define-external (readline_event_hook) void
  (and-let* ((proc ((foreign-primitive scheme-object ()
                     "C_return(CHICKEN_gc_root_ref(readline_event_hook_proc));"))))
    (proc)))

(define-external (readline_pre_input_hook) void
  (and-let* ((proc ((foreign-primitive scheme-object ()
                     "C_return(CHICKEN_gc_root_ref(readline_pre_input_hook_proc));"))))
    (proc)))

(define-external (readline_redisplay_function) void
  (and-let* ((proc ((foreign-primitive scheme-object ()
                     "C_return(CHICKEN_gc_root_ref(readline_redisplay_function_proc));"))))
    (proc)))

(define (check-proc x)
  (when (and x (not (procedure? x)))
    (error "bad argument type - not a procedure" x)))

(define (event-hook-set! proc)
  (check-proc proc)
  (if proc
      ((foreign-lambda* void ((scheme-object hook))
         "CHICKEN_gc_root_set(readline_event_hook_proc, hook);"
         "rl_event_hook = (rl_hook_func_t *)readline_event_hook;")
       proc)
      ((foreign-lambda* void ()
         "CHICKEN_gc_root_set(readline_event_hook_proc, C_SCHEME_FALSE);"
         "rl_event_hook = NULL;"))))

(define (pre-input-hook-set! proc)
  (check-proc proc)
  (if proc
      ((foreign-lambda* void ((scheme-object hook))
         "CHICKEN_gc_root_set(readline_pre_input_hook_proc, hook);"
         "rl_pre_input_hook = (rl_hook_func_t *)readline_pre_input_hook;")
       proc)
      ((foreign-lambda* void ()
         "CHICKEN_gc_root_set(readline_pre_input_hook_proc, C_SCHEME_FALSE);"
         "rl_pre_input_hook = NULL;"))))

(define (redisplay-function-set! proc)
  (check-proc proc)
  (if proc
      ((foreign-lambda* void ((scheme-object func))
         "CHICKEN_gc_root_set(readline_redisplay_function_proc, func);"
         "rl_redisplay_function = readline_redisplay_function;")
       proc)
      ((foreign-lambda* void ()
         "CHICKEN_gc_root_set(readline_redisplay_function_proc, C_SCHEME_FALSE);"
         "rl_redisplay_function = rl_redisplay;"))))

;;; Alternate callback-based interface

#>

void *readline_callback_handler_proc;

<#

(define callback-handler-install! (foreign-safe-lambda void rl_callback_handler_install c-string c-pointer))
(define callback-handler-remove! (foreign-lambda void rl_callback_handler_remove))
(define callback-signal-cleanup! (foreign-lambda void rl_callback_sigcleanup))
(define callback-read-char! (foreign-safe-lambda void rl_callback_read_char))

(foreign-code
 ;; rl_callback_handler_install
 "readline_callback_handler_proc = CHICKEN_new_gc_root();"
 "CHICKEN_gc_root_set(readline_callback_handler_proc, C_SCHEME_FALSE);")

(define-external (readline_callback_handler (c-string* line)) void
  (and-let* ((proc ((foreign-primitive scheme-object ()
                     "C_return(CHICKEN_gc_root_ref(readline_callback_handler_proc));"))))
    (proc line)))

(define (callback-handler-set! #!optional prompt proc)
  (check-proc proc)
  ((foreign-lambda* void ((scheme-object proc))
     "CHICKEN_gc_root_set(readline_callback_handler_proc, proc);")
   proc)
  (if prompt
      (callback-handler-install! prompt (location readline_callback_handler))
      (callback-handler-remove!)))

;;; REPL integration

(define readline
  (foreign-safe-lambda c-string* "readline" (const nonnull-c-string)))

(define (prompt->string prompt)
  (cond
   ((procedure? prompt) (prompt))
   ((string? prompt) prompt)
   (else (let ((message (format "Bad argument type - not a string: ~a" prompt)))
           (abort
            (condition `(exn location prompt->string message ,message) '(type)))))))

(define (make-readline-port #!optional prompt)
  (letrec ((buffer "")
           (position 0)
           (port #f)
           (read-char
            (lambda ()
              (cond
               ((not buffer)
                #!eof)
               ((char-ready?)
                (let ((char (string-ref buffer position)))
                  (set! position (add1 position))
                  char))
               (else
                (set! position 0)
                (call-with-current-continuation
                 (lambda (k)
                   (callback-handler-set!
                    (prompt->string (or prompt (repl-prompt)))
                    (lambda (result)
                      (set! buffer result)
                      (when buffer
                        (add-history! buffer)
                        (set! buffer (string-append buffer "\n")))
                      (callback-handler-set!)
                      (k (read-char))))
                   (handle-exceptions e
                       (begin (set! buffer "") (callback-handler-set!) (signal e))
                     (let loop ()
                       (thread-wait-for-i/o! 0 #:input)
                       (callback-read-char!)
                       (loop)))))))))
           (char-ready? (lambda () (< position (string-length buffer))))
           (close (lambda () #f)))
    (when (and (history-file) (file-exists? (history-file)))
      (read-history! (history-file)))
    (set! port (make-input-port read-char char-ready? close))
    (set-port-name! port "(readline)")
    (when (history-file)
      (set-finalizer! port (lambda (p) (write-history! (history-file))))
      (on-exit (lambda () (write-history! (history-file)))))
    port))