;;; Lisparuga
;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu>
;;;
;;; Lisparuga is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; Lisparuga 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
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Lisparuga.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; REPL for live hacking and debugging.
;;
;;; Code:

(define-module (lisparuga repl)
  #:use-module (oop goops)
  #:use-module (ice-9 match)
  #:use-module (lisparuga node)
  #:use-module (system repl coop-server)
  #:use-module (system repl debug)
  #:use-module (system repl repl)
  #:export (<repl>
            repl-server
            repl-debug
            repl-debugging?
            on-error
            debugger))

(define-class <repl> (<node>)
  (repl-server #:accessor repl-server)
  (repl-debug #:accessor repl-debug #:init-form #f)
  (repl-debugging? #:accessor repl-debugging? #:init-form #f))

(define-method (on-boot (repl <repl>))
  (set! (repl-server repl) (spawn-coop-repl-server)))

(define-method (on-error (repl <repl>) stack key args)
  ;; Display backtrace.
  (let ((port (current-error-port)))
    (display "an error has occurred!\n\n" port)
    (display "Backtrace:\n" port)
    (display-backtrace stack port)
    (newline port)
    (match args
      ((subr message . args)
       (display-error (stack-ref stack 0) port subr message args '())))
    (newline port))
  ;; Setup the REPL debug object.
  (let* ((tag (and (pair? (fluid-ref %stacks))
                   (cdr (fluid-ref %stacks))))
         (stack (narrow-stack->vector
                 stack
                 ;; Take the stack from the given frame, cutting 0
                 ;; frames.
                 0
                 ;; 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)
                 ))
         (error-string (call-with-output-string
                         (lambda (port)
                           (let ((frame (and (< 0 (vector-length stack))
                                             (vector-ref stack 0))))
                             (print-exception port frame key args))))))
    (set! (repl-debug repl) (make-debug stack 0 error-string))
    (set! (repl-debugging? repl) #t)
    ;; Wait for the user to exit the debugger.
    (display "waiting for developer to debug..." (current-error-port))
    (while (repl-debugging? repl)
      (poll-coop-repl-server (repl-server repl))
      (usleep 160000)
      #t)
    (set! (repl-debug repl) #f)
    (display " done!\n")))

(define-method (update (repl <repl>) dt)
  (poll-coop-repl-server (repl-server repl)))

(define-method (debugger (repl <repl>))
  (if (repl-debug repl)
      (begin
        (format #t "~a~%" (debug-error-message (repl-debug repl)))
        (format #t "Entering a new prompt.  ")
        (format #t "Type `,bt' for a backtrace or `,q' to resume the game loop.\n")
        (start-repl #:debug (repl-debug repl))
        (set! (repl-debugging? repl) #f))
      (display "nothing to debug!\n")))