;;; Chickadee Game Toolkit
;;; Copyright © 2021 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary
;;
;; GNU readline bindings for use with the Chickadee REPL.  The
;; guile-readline C extension is not compatible with the alternative,
;; callback-based readline interface so here comes the FFI to the
;; rescue.
;;
;;; Code:

(define-module (chickadee readline)
  #:use-module (chickadee config)
  #:use-module (system foreign)
  #:export (bind-readline-variable
            install-readline-handler
            remove-readline-handler
            readline-read-char
            add-readline-history))

;;;
;;; Setup
;;;

(define libreadline (dynamic-link* %libreadline))

(define (readline-func return-type function-name arg-types)
  (pointer->procedure return-type
                      (dynamic-func function-name libreadline)
                      arg-types))

(define-syntax-rule (define-foreign name return-type func-name arg-types)
  (define name
    (readline-func return-type func-name arg-types)))

;;;
;;; Variables
;;;

(define-foreign rl-variable-bind void "rl_variable_bind" '(* *))

(define (bind-readline-variable name value)
  (rl-variable-bind (string->pointer name) (string->pointer value)))

;;;
;;; Callbacks
;;;

(define-foreign rl-callback-handler-install void "rl_callback_handler_install" '(* *))
(define-foreign rl-callback-handler-remove void "rl_callback_handler_remove" '())
(define-foreign rl-callback-read-char void "rl_callback_read_char" '())
(define-foreign rl-callback-sigcleanup void "rl_callback_sigcleanup" '())

(define (install-readline-handler prompt proc)
  (let ((proc-ptr (procedure->pointer void
                                      (lambda (ptr)
                                        (proc (if (null-pointer? ptr)
                                                  ""
                                                  (pointer->string ptr))))
                                      '(*))))
    (rl-callback-handler-install (string->pointer prompt) proc-ptr)))

(define (remove-readline-handler)
  (rl-callback-handler-remove))

(define (readline-read-char)
  (rl-callback-read-char))

;;;
;;; History
;;;

(define-foreign add-history void "add_history" '(*))

(define (add-readline-history line)
  (add-history (string->pointer line)))