From a5b66029d38eb74e2cc65593eb068eeddf868448 Mon Sep 17 00:00:00 2001
From: Calvin Rose <calsrose@gmail.com>
Date: Fri, 10 Jun 2022 15:23:15 -0500
Subject: [PATCH] Expose the built-in debugger in more places.

---
 CHANGELOG.md        |   4 ++
 src/boot/boot.janet | 105 +++++++++++++++++++++++++-------------------
 2 files changed, 64 insertions(+), 45 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index ef5f9242..bac809f8 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -2,6 +2,10 @@
 All notable changes to this project will be documented in this file.
 
 ## Unreleased - ???
+- `dofile` will now start a debugger on errors if the environment it is passed has `:debug` set.
+- Add `debugger-on-status` function, which can be passed to `run-context` to start a debugger on
+  abnormal fiber signals.
+- Allow running scripts with the `-d` flag to use the built-in debugger on errors and breakpoints.
 - Add `raw-native`, `native-lookup`, and `native-close` for interfacing with dynamic libraries.
 - Add mutexes (locks) and reader-writer locks to ev module for thread coordination.
 - Add `parse-all` as a generalization of the `parse` function.
diff --git a/src/boot/boot.janet b/src/boot/boot.janet
index 8d78fd12..802e601b 100644
--- a/src/boot/boot.janet
+++ b/src/boot/boot.janet
@@ -2746,6 +2746,49 @@
         (get r 0)
         v))))
 
+(def debugger-env
+  "An environment that contains dot prefixed functions for debugging."
+  @{})
+
+(defn debugger-on-status
+  "Create a function that can be passed to `run-context`'s `:on-status`
+  argument that will drop into a debugger on errors."
+  [env &opt level is-repl]
+  (default level 1)
+  (defn enter-debugger
+    [f x]
+    (def nextenv (make-env env))
+    (put nextenv :fiber f)
+    (put nextenv :debug-level level)
+    (put nextenv :signal x)
+    (merge-into nextenv debugger-env)
+    (defn debugger-chunks [buf p]
+      (def status (:state p :delimiters))
+      (def c ((:where p) 0))
+      (def prpt (string "debug[" level "]:" c ":" status "> "))
+      (getline prpt buf nextenv))
+    (print "entering debug[" level "] - (quit) to exit")
+    (flush)
+    (run-context
+      {:chunks debugger-chunks
+       :on-status (debugger-on-status nextenv (+ 1 level) true)
+       :env nextenv})
+    (print "exiting debug[" level "]")
+    (flush)
+    (nextenv :resume-value))
+  (fn [f x]
+    (def fs (fiber/status f))
+    (if (= :dead fs)
+      (when is-repl
+        (put env '_ @{:value x})
+        (printf (get env :pretty-format "%q") x)
+        (flush))
+      (do
+        (debug/stacktrace f x "")
+        (eflush)
+        (if (get env :debug) (enter-debugger f x))))))
+
+
 (defn dofile
   ``Evaluate a file, file path, or stream and return the resulting environment. :env, :expander,
   :source, :evaluator, :read, and :parser are passed through to the underlying
@@ -2802,9 +2845,12 @@
                                    (debug/stacktrace f x "")
                                    (eflush)
                                    (os/exit 1))
-                                 (put env :exit true)
-                                 (set exit-error x)
-                                 (set exit-fiber f)))
+                                 (if (get env :debug)
+                                   ((debugger-on-status env) f x)
+                                   (do
+                                     (put env :exit true)
+                                     (set exit-error x)
+                                     (set exit-fiber f)))))
                   :evaluator evaluator
                   :expander expander
                   :read read
@@ -3448,10 +3494,6 @@
     (set res (debug/step (.fiber))))
   res)
 
-(def debugger-env
-  "An environment that contains dot prefixed functions for debugging."
-  @{})
-
 (def- debugger-keys (filter (partial string/has-prefix? ".") (keys root-env)))
 (each k debugger-keys (put debugger-env k (root-env k)) (put root-env k nil))
 
@@ -3479,43 +3521,9 @@
           ":"
           (:state p :delimiters) "> ")
         buf env)))
-  (defn make-onsignal
-    [e level]
-
-    (defn enter-debugger
-      [f x]
-      (def nextenv (make-env env))
-      (put nextenv :fiber f)
-      (put nextenv :debug-level level)
-      (put nextenv :signal x)
-      (merge-into nextenv debugger-env)
-      (defn debugger-chunks [buf p]
-        (def status (:state p :delimiters))
-        (def c ((:where p) 0))
-        (def prpt (string "debug[" level "]:" c ":" status "> "))
-        (getline prpt buf nextenv))
-      (print "entering debug[" level "] - (quit) to exit")
-      (flush)
-      (repl debugger-chunks (make-onsignal nextenv (+ 1 level)) nextenv)
-      (print "exiting debug[" level "]")
-      (flush)
-      (nextenv :resume-value))
-
-    (fn [f x]
-      (def fs (fiber/status f))
-      (if (= :dead fs)
-        (do
-          (put e '_ @{:value x})
-          (printf (get e :pretty-format "%q") x)
-          (flush))
-        (do
-          (debug/stacktrace f x "")
-          (eflush)
-          (if (e :debug) (enter-debugger f x))))))
-
   (run-context {:env env
                 :chunks chunks
-                :on-status (or onsignal (make-onsignal env 1))
+                :on-status (or onsignal (debugger-on-status env 1 true))
                 :parser parser
                 :read read
                 :source :repl}))
@@ -3682,10 +3690,17 @@
 
 (defn- run-main
   [env subargs arg]
-  (if-let [entry (in env 'main)
+  (when-let [entry (in env 'main)
            main (or (get entry :value) (in (get entry :ref) 0))]
-    (let [thunk (compile [main ;subargs] env arg)]
-      (if (function? thunk) (thunk) (error (thunk :error))))))
+    (def guard (if (get env :debug) :ydt :y))
+    (defn wrap-main [&]
+      (main ;subargs))
+    (def f (fiber/new wrap-main guard))
+    (fiber/setenv f env)
+    (while (fiber/can-resume? f)
+      (def res (resume f))
+      (when (not= :dead (fiber/status f))
+        ((debugger-on-status env) f res)))))
 
 (defdyn *args*
   "Dynamic bindings that will contain command line arguments at program start.")