Add live coding/debugging REPL server.

4 files changed, 142 insertions, 5 deletions

diff --git a/Makefile.am b/Makefile.am
index e80b15e..49313d9 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -40,6 +40,7 @@ godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
 SOURCES = 					\
   starling/node.scm				\
   starling/node-2d.scm				\
+  starling/repl.scm				\
   starling/kernel.scm
 
 EXTRA_DIST += 					\
diff --git a/guix.scm b/guix.scm
index 05161db..d2ed68d 100644
--- a/guix.scm
+++ b/guix.scm
@@ -117,7 +117,7 @@ SDL2 C shared library via the foreign function interface.")
       (license lgpl3+))))
 
 (define chickadee
-  (let ((commit "8163e4b415bcf1f6a696ccbf06e3136aea1a261f"))
+  (let ((commit "7d64cb370bd5abcdaed9215a33bc450c0bb21bf4"))
     (package
      (name "chickadee")
      (version "0.1")
@@ -128,7 +128,7 @@ SDL2 C shared library via the foreign function interface.")
                     (commit commit)))
               (sha256
                (base32
-                "0wsn01mxvmkgfmc7s97hq5vwi86p5qn0bylxi3ilbp0b7i9g7x50"))))
+                "1369ij1xyqzjgp7fxsx76h1imhhvj722yvrw6rgv1723rgw5ppcq"))))
      (build-system gnu-build-system)
      (arguments
       '(#:make-flags '("GUILE_AUTO_COMPILE=0")
diff --git a/starling/kernel.scm b/starling/kernel.scm
index caab692..1ff6b1a 100644
--- a/starling/kernel.scm
+++ b/starling/kernel.scm
@@ -24,6 +24,7 @@
 
 (define-module (starling kernel)
   #:use-module (chickadee)
+  #:use-module (chickadee render gpu)
   #:use-module (ice-9 match)
   #:use-module (oop goops)
   #:use-module (sdl2)
@@ -34,6 +35,8 @@
   #:use-module (sdl2 mixer)
   #:use-module (sdl2 video)
   #:use-module (starling node)
+  #:use-module (starling repl)
+  #:use-module (system repl command)
   #:export (on-quit
             on-key-press
             on-key-release
@@ -56,6 +59,7 @@
             update-hz
             window
             gl-context
+            current-kernel
             boot-kernel)
   #:re-export (abort-game))
 
@@ -106,9 +110,11 @@
   (name #:accessor name #:init-form "starling-kernel")
   (window-config #:accessor window-config #:init-form (make <window-config>))
   (update-hz #:accessor update-hz #:init-form 60)
+  (developer-mode? #:getter developer-mode? #:init-form #t)
   (window #:accessor window)
   (gl-context #:accessor gl-context)
-  (controllers #:accessor controllers #:init-thunk make-hash-table))
+  (controllers #:accessor controllers #:init-thunk make-hash-table)
+  (repl #:accessor repl))
 
 (define current-kernel (make-parameter #f))
 
@@ -134,6 +140,10 @@
         (add-controller kernel i))
       (loop (+ i 1)))))
 
+(define-method (on-boot (kernel <kernel>))
+  (when (developer-mode? kernel)
+    (attach-to kernel (make <repl> #:name 'repl #:rank 9999))))
+
 (define-method (update* (kernel <kernel>) dt)
   (define (invert-y y)
     ;; SDL's origin is the top-left, but our origin is the bottom
@@ -214,7 +224,7 @@
                               controller
                               (controller-axis-event-axis event)
                               (/ (controller-axis-event-value event) 32768.0)))))))
-  ;; Process all pending events.
+  ;; Process all pending events before we update any other node.
   (let loop ((event (poll-event)))
     (when event
       (process-event event)
@@ -222,6 +232,18 @@
   ;; Proceed with standard update procedure.
   (next-method))
 
+(define-method (update (kernel <kernel>) dt)
+  ;; Free any GPU resources that have been GC'd.
+  (gpu-reap!))
+
+(define-method (on-error (kernel <kernel>) stack key args)
+  (if (developer-mode? kernel)
+      (let ((title (window-title (window kernel))))
+        (set-window-title! (window kernel) (string-append "[ERROR] " title))
+        (on-error (& kernel repl) stack key args)
+        (set-window-title! (window kernel) title))
+      (apply throw key args)))
+
 (define (boot-kernel kernel first-node)
   (sdl-init)
   ;; This will throw an error if any audio subsystem is unavailable,
@@ -240,17 +262,36 @@
                        #:size (list (width wc) (height wc))
                        #:fullscreen? (fullscreen? wc)))
     (set! (gl-context kernel) (make-gl-context (window kernel)))
+    ;; Attempt to activate vsync, if possible.  Some systems do
+    ;; not support setting the OpenGL swap interval.
+    (catch #t
+      (lambda ()
+        (set-gl-swap-interval! 'vsync))
+      (lambda args
+        (display "warning: could not enable vsync\n"
+                 (current-error-port))))
     (dynamic-wind
       (const #t)
       (lambda ()
         (parameterize ((current-kernel kernel))
           (attach-to kernel first-node)
           (activate kernel)
-          ;; TODO: Add error handler
           (run-game #:update (lambda (dt) (update* kernel dt))
                     #:render (lambda (alpha) (render* kernel alpha))
+                    #:error (lambda (stack key args)
+                              (on-error kernel stack key args))
                     #:time sdl-ticks
                     #:update-hz (update-hz kernel))))
       (lambda ()
         (deactivate kernel)
         (close-window! (window kernel))))))
+
+(define-meta-command ((debug-game starling) repl)
+  "debug-game
+Enter a debugger for the current game loop error."
+  (debugger (& (current-kernel) repl)))
+
+(define-meta-command ((resume-game starling) repl)
+  "resume-game
+Resume the game loop without entering a debugger."
+  (set! (repl-debugging? (& (current-kernel) repl)) #f))
diff --git a/starling/repl.scm b/starling/repl.scm
new file mode 100644
index 0000000..994ddbc
--- /dev/null
+++ b/starling/repl.scm
@@ -0,0 +1,95 @@
+;;; Starling Game Engine
+;;; Copyright © 2018 David Thompson <davet@gnu.org>
+;;;
+;;; This program 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.
+;;;
+;;; This program 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 Starling.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; REPL for live hacking and debugging.
+;;
+;;; Code:
+
+(define-module (starling repl)
+  #:use-module (oop goops)
+  #:use-module (starling 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)
+    (apply display-error (stack-ref stack 0) port 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))
+      #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")))