summaryrefslogtreecommitdiff
path: root/starling/repl.scm
diff options
context:
space:
mode:
Diffstat (limited to 'starling/repl.scm')
-rw-r--r--starling/repl.scm145
1 files changed, 145 insertions, 0 deletions
diff --git a/starling/repl.scm b/starling/repl.scm
new file mode 100644
index 0000000..47947c0
--- /dev/null
+++ b/starling/repl.scm
@@ -0,0 +1,145 @@
+;;; 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 node for in-engine live hacking.
+;;
+;;; Code:
+
+(define-module (starling repl)
+ #:use-module (chickadee array-list)
+ #:use-module (chickadee graphics color)
+ #:use-module (chickadee graphics font)
+ #:use-module (chickadee math rect)
+ #:use-module (chickadee math vector)
+ #:use-module (chickadee scripting)
+ #:use-module (ice-9 eval-string)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (oop goops)
+ #:use-module (starling ring-buffer)
+ #:use-module (starling node)
+ #:use-module (starling node-2d)
+ #:use-module (starling scene)
+ #:export (<repl>
+ open-repl))
+
+(define-class <repl> (<scene-2d>)
+ (scene-mux #:getter scene-mux #:init-keyword #:scene-mux)
+ (overlay-scene #:accessor overlay-scene #:init-keyword #:overlay-scene)
+ (lines #:accessor lines #:init-form '())
+ (log #:accessor log)
+ (user-text #:accessor user-text #:init-form "")
+ (module #:accessor module #:init-form (resolve-module '(guile-user))))
+
+(define-method (open-repl repl)
+ (set! (overlay-scene repl) (current-scene (scene-mux repl)))
+ (push-scene (scene-mux repl) repl))
+
+(define-method (close-repl (repl <repl>))
+ (pop-scene (scene-mux repl)))
+
+(define-method (modify-user-text (repl <repl>) new-text)
+ (set! (user-text repl) new-text)
+ (set! (text (& repl prompt))
+ (format #f "~s> ~a" (module-name (module repl)) new-text)))
+
+(define-method (backward-delete (repl <repl>))
+ (let ((text (user-text repl)))
+ (modify-user-text repl
+ (substring text 0 (max (- (string-length text) 1) 0)))))
+
+(define-method (eval-user-text (repl <repl>))
+ (let* ((result #f)
+ (output (with-output-to-string
+ (lambda ()
+ (set! result (eval-string (user-text repl)
+ #:module (module repl))))))
+ (log (log repl)))
+ (for-each (lambda (line)
+ (ring-buffer-put! log line))
+ (let ((result-text (if (unspecified? result)
+ ""
+ (with-output-to-string
+ (lambda ()
+ (display "=> ")
+ (write result))))))
+ (match (string-split (string-append (text (& repl prompt))
+ "\n" output result-text)
+ #\newline)
+ ;; Drop trailing newlines
+ ((lines ... "") lines)
+ (lines lines))))
+ (let loop ((i 0)
+ (labels (lines repl)))
+ (when (< i (ring-buffer-length log))
+ (match labels
+ ((label . rest)
+ (set! (text label) (ring-buffer-ref log i))
+ (loop (+ i 1) rest)))))
+ (modify-user-text repl "")))
+
+(define-method (on-boot (repl <repl>))
+ (let* ((res (resolution (car (cameras repl))))
+ (font (default-font))
+ (line-height (font-line-height font))
+ (left-margin 6.0)
+ (bottom-margin 6.0)
+ (nlines (- (inexact->exact
+ (floor
+ (/ (vec2-y res) line-height)))
+ 1))
+ (line-nodes
+ (map (lambda (i)
+ (make <label>
+ #:rank 9
+ #:font font
+ #:position (vec2 left-margin
+ (- (vec2-y res)
+ (* i line-height)))
+ #:vertical-align 'top))
+ (iota nlines))))
+ (attach-to repl
+ (make <filled-rect>
+ #:region (make-rect 0.0 0.0 (vec2-x res) (vec2-y res))
+ #:color (make-color 0.0 0.0 0.0 0.7))
+ (make <label>
+ #:rank 9
+ #:name 'prompt
+ #:position (vec2 left-margin bottom-margin)))
+ (apply attach-to repl line-nodes)
+ (set! (lines repl) line-nodes)
+ (set! (log repl) (make-ring-buffer nlines))
+ (modify-user-text repl "")))
+
+(define-method (update (repl <repl>) dt)
+ (update-tree (overlay-scene repl) dt)
+ (next-method))
+
+(define-method (render (repl <repl>) alpha)
+ (render-tree (overlay-scene repl) alpha)
+ (next-method))
+
+(define-method (on-key-press (repl <repl>) key modifiers repeat?)
+ (match key
+ ('escape (close-repl repl))
+ ('backspace (backward-delete repl))
+ ('return (eval-user-text repl))
+ (_ #f)))
+
+(define-method (on-text-input (repl <repl>) text)
+ (modify-user-text repl (string-append (user-text repl) text)))