summaryrefslogtreecommitdiff
path: root/starling/repl.scm
blob: cfaf5b00e255504bec231f84a87f1a637c453af2 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
;;; 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 (ice-9 match)
  #: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)
    (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")))