;;; 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
;;
;; Non-blocking terminal REPL with readline support.
;;
;;; Code:

(define-module (chickadee async-repl)
  #:use-module (chickadee readline)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (srfi srfi-9)
  #:use-module (system base language)
  #:use-module (system repl common)
  #:use-module (system repl debug)
  #:export (make-async-repl
            async-repl?
            set-async-repl-debug!
            start-async-debugger
            start-async-repl
            update-async-repl
            close-async-repl))

;; Need to access some private API things.
(define run-repl* (@@ (system repl repl) run-repl*))
(define meta-command-token (@@ (system repl repl) meta-command-token))

(define %async-repl-prompt-tag (make-prompt-tag 'async-repl))

(define-record-type <async-repl>
  (%make-async-repl input-port output-port)
  async-repl?
  (input-port async-repl-input-port)
  (output-port async-repl-output-port)
  (state async-repl-state set-async-repl-state!)
  (cont async-repl-cont set-async-repl-cont!)
  (debug async-repl-debug set-async-repl-debug!)  )

(define (async-repl-waiting? repl)
  (eq? (async-repl-state repl) 'waiting))

(define (async-repl-ready? repl)
  (eq? (async-repl-state repl) 'ready))

(define (async-repl-send repl line)
  (let ((output-port (async-repl-output-port repl)))
    (add-readline-history line)
    (display line output-port)
    (newline output-port)
    (force-output output-port)
    (set-async-repl-state! repl 'ready)))

(define* (make-async-repl)
  ;; Need non-blocking I/O.
  (install-suspendable-ports!)
  ;; Our REPL is not going to read from standard input, but instead
  ;; from the input port of a pipe.  Readline will read from
  ;; standard input and then we will pass that text along through
  ;; the pipe to the REPL.
  (match (pipe)
    ((input-port . output-port)
     ;; Set input port to non-blocking mode.
     (let ((flags (fcntl input-port F_GETFL)))
       (fcntl input-port F_SETFL (logior O_NONBLOCK flags)))
     (%make-async-repl input-port output-port))))

(define* (async-repl-prompt repl prompt)
  (install-readline-handler prompt
                            (lambda (line)
                              (async-repl-send repl line)
                              (remove-readline-handler)))
  (set-async-repl-state! repl 'waiting)
  ;; Suspend the REPL until readline tells us that the user has
  ;; input a new line.
  (abort-to-prompt %async-repl-prompt-tag (current-dynamic-state)))

(define (run-async-repl repl debug)
  (define (repl-read repl*)
    (define (flush-leading-whitespace)
      (let ((c (peek-char)))
        (cond
         ((eof-object? c) #t)
         ((char-whitespace? c)
          (read-char)
          (flush-leading-whitespace))
         (else #t))))
    (define (read-expression)
      (when (char-ready?)
        (flush-leading-whitespace)
        (let ((c (peek-char)))
          (cond
           ((eof-object? c) ; end of file
            (read-char)
            *unspecified*)
           ((eqv? c #\,) ; metacommand
            (read-char) ; need to read first char
            meta-command-token)
           ((eqv? c #\;) ; comment
            (read-line)
            *unspecified*)
           (else ; read code using current language reader
            (parameterize ((current-read-waiter
                            (lambda (port)
                              ;; If 'read' doesn't complete because it
                              ;; needs more input, then prompt the user
                              ;; for another line.
                              (async-repl-prompt repl "...> "))))
              (let ((read (language-reader (repl-language repl*))))
                (read (current-input-port) (current-module)))))))))
    ;; Check if there are more expressions to process from the
    ;; previous user input before prompting for new input.
    (if (char-ready?)
        (read-expression)
        (let ((debug (async-repl-debug repl)))
          ;; If we have debug info then it's time to launch a sub-REPL to
          ;; do the debugging.
          (when debug
            (set-async-repl-debug! repl #f)
            (format #t "~a~%" (debug-error-message debug))
            (format #t "Entering a new prompt.  ")
            (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
            (run-async-repl repl debug))
          (async-repl-prompt repl (repl-prompt repl*))
          (read-expression))))
  (define (error-string stack key args)
    (call-with-output-string
      (lambda (port)
        (let ((frame (and (< 0 (vector-length stack)) (vector-ref stack 0))))
          (print-exception port frame key args)))))
  (define (on-error key . args)
    (unless (eq? key 'quit)
      (let* ((tag (and (pair? (fluid-ref %stacks))
                       (cdr (fluid-ref %stacks))))
             (stack (narrow-stack->vector
                     (make-stack #t)
                     ;; Cut three frames from the top of the stack:
                     ;; make-stack, this one, and the throw handler.
                     3
                     ;; Narrow the end of the stack to the most recent
                     ;; start-stack.
                     tag
                     ;; And one more frame, because %start-stack invoking
                     ;; the start-stack thunk has its own frame too.
                     0 (and tag 1)))
             (debug (make-debug stack 0 (error-string stack key args))))
        ;; We cannot jump right into the debugger REPL here because
        ;; there are C frames in the stack.  This means that we cannot
        ;; resume any continuations we create via abort-to-prompt.
        ;; Instead, we record the debugger object so that the next
        ;; time the REPL reader procedure is called we can jump
        ;; straight into a debugging REPL.
        (set-async-repl-debug! repl debug))))
  ;; The user can change the module from inside the REPL, and we don't
  ;; want that to affect the outside environment when the user exits
  ;; the REPL.
  (save-module-excursion
   (lambda ()
     (let ((repl* (make-repl (current-language) debug)))
       ;; The REPL implementation allows custom procedures for the on-error
       ;; handler, but the validator only accepts symbols!  So, we just
       ;; mutate the dang options ourselves.
       (match (assq 'on-error (repl-options repl*))
         ((_ . spec)
          (set-car! spec on-error)))
       (run-repl* repl* repl-read)))))

(define* (start-async-repl repl #:optional (on-quit (const #t)))
  (bind-readline-variable "blink-matching-paren" "on")
  (parameterize ((current-input-port (async-repl-input-port repl)))
    (define-syntax-rule (with-repl-prompt body ...)
      (call-with-prompt %async-repl-prompt-tag
        (lambda () body ...)
        handler))
    (define (handler k state)
      (define (resume)
        (with-repl-prompt (with-dynamic-state state k)))
      (set-async-repl-cont! repl resume))
    (with-repl-prompt
     (run-async-repl repl #f)
     (on-quit))))

(define (update-async-repl repl)
  (when (and (async-repl-waiting? repl) (char-ready?))
    (readline-read-char)
    (when (async-repl-ready? repl)
      (set-async-repl-state! repl 'running)
      ((async-repl-cont repl)))))

(define (close-async-repl repl)
  (close-port (async-repl-input-port repl))
  (close-port (async-repl-output-port repl))
  (remove-readline-handler)
  (newline))