Add highlight.janet tool which can highlight

janet source code and output html or terminal escaped code.
Also made re entrant calls into the vm provide better
error messages.

doc/Peg.md

@@ -150,7 +150,8 @@ that can make many grammars simpler.
 | `(cmt patt fun ?tag)` | Invokes fun with all of the captures of patt as arguments (if patt matches). If the result is truthy, then captures the result. The whole expression fails if fun returns false or nil. |
 | `(backref tag ?tag)` | Duplicates the last capture with the tag `tag`. If no such capture exists then the match fails. |
 | `(-> tag ?tag)` | Alias for `(backref tag)`. |
-| `(error patt)` | Throws a Janet error if patt matches. The error thrown will be the last capture ofpatt, or a generic error if patt produces no captures. |
+| `(error patt)` | Throws a Janet error if patt matches. The error thrown will be the last capture of patt, or a generic error if patt produces no captures. |
+| `(drop patt)` | Ignores (drops) all captures from patt. |
 
 ## Grammars and Recursion
 

src/core/core.janet

@@ -92,7 +92,7 @@
 (defn function? "Check if x is a function (not a cfunction)." [x]
   (= (type x) :function))
 (defn cfunction? "Check if x a cfunction." [x] (= (type x) :cfunction))
-(defn table? "Check if x a table." [x] (= (type x) :table ))
+(defn table? "Check if x a table." [x] (= (type x) :table))
 (defn struct? "Check if x a struct." [x] (= (type x) :struct))
 (defn array? "Check if x is an array." [x] (= (type x) :array))
 (defn tuple? "Check if x is a tuple." [x] (= (type x) :tuple))

src/core/peg.c

@@ -53,6 +53,7 @@ typedef enum {
     RULE_REPLACE,      /* [rule, constant, tag] */
     RULE_MATCHTIME,    /* [rule, constant, tag] */
     RULE_ERROR,        /* [rule] */
+    RULE_DROP,         /* [rule] */
 } Opcode;
 
 /* Hold captured patterns and match state */
@@ -350,6 +351,17 @@ tail:
                 return result;
             }
 
+        case RULE_DROP:
+            {
+                CapState cs = cap_save(s);
+                down1(s);
+                const uint8_t *result = peg_rule(s, s->bytecode + rule[1], text);
+                up1(s);
+                if (!result) return NULL;
+                cap_load(s, cs);
+                return result;
+            }
+
         case RULE_GROUP:
             {
                 uint32_t tag = rule[2];
@@ -750,6 +762,9 @@ static void spec_not(Builder *b, int32_t argc, const Janet *argv) {
 static void spec_error(Builder *b, int32_t argc, const Janet *argv) {
     spec_onerule(b, argc, argv, RULE_ERROR);
 }
+static void spec_drop(Builder *b, int32_t argc, const Janet *argv) {
+    spec_onerule(b, argc, argv, RULE_DROP);
+}
 
 /* Rule of the form [rule, tag] */
 static void spec_cap1(Builder *b, int32_t argc, const Janet *argv, uint32_t op) {
@@ -854,6 +869,7 @@ static const SpecialPair specials[] = {
     {"choice", spec_choice},
     {"cmt", spec_matchtime},
     {"constant", spec_constant},
+    {"drop", spec_drop},
     {"error", spec_error},
     {"group", spec_group},
     {"if", spec_if},

src/core/vm.c

@@ -758,18 +758,30 @@ Janet janet_call(JanetFunction *fun, int32_t argc, const Janet *argv) {
     JanetFiber *fiber = janet_fiber(fun, 64, argc, argv);
     if (!fiber)
         janet_panic("arity mismatch");
+    JanetFiber *old_fiber = janet_vm_fiber;
+    janet_vm_fiber = fiber;
+    janet_gcroot(janet_wrap_fiber(fiber));
+    int32_t oldn = janet_vm_stackn++;
     int handle = janet_gclock();
 
-    JanetFiber *old_fiber = janet_vm_fiber;
-    old_fiber->child = fiber;
-    janet_vm_fiber = fiber;
-    memcpy(fiber->buf, janet_vm_fiber->buf,  sizeof(jmp_buf));
-    run_vm(fiber, janet_wrap_nil(), JANET_STATUS_NEW);
-    old_fiber->child = NULL;
-    janet_vm_fiber = old_fiber;
+    JanetSignal signal;
+    if (setjmp(fiber->buf)) {
+        signal = JANET_SIGNAL_ERROR;
+    } else {
+        signal = run_vm(fiber, janet_wrap_nil(), JANET_STATUS_NEW);
+    }
 
+    janet_vm_stackn = oldn;
+    janet_vm_fiber = old_fiber;
+    Janet ret = fiber->data[fiber->stacktop - 1];
+    janet_gcunroot(janet_wrap_fiber(fiber));
     janet_gcunlock(handle);
-    return fiber->data[fiber->stacktop - 1];
+    if (signal == JANET_SIGNAL_ERROR) {
+        old_fiber->child = fiber;
+        janet_fiber_set_status(fiber, signal);
+        janet_panicv(ret);
+    }
+    return ret;
 }
 
 /* Enter the main vm loop */

tools/highlight.janet

@@ -0,0 +1,210 @@
+# Copyright (C) Calvin Rose 2019
+#
+# Takes in a janet string and colorizes for multiple
+# output formats.
+
+# Constants for checking if symbols should be
+# highlighted.
+(def- core-env (table/getproto _env))
+(def- specials {'fn true
+               'var true
+               'do true
+               'while true
+               'def true
+               'splice true
+               'set true
+               'unquote true
+               'quasiquote true
+               'quote true
+               'if true})
+
+(defn check-number [text] (and (scan-number text) text))
+
+(defn- make-grammar
+  "Creates the grammar based on the paint function and some
+  wraping constants."
+  [paint]
+
+  (defn <-c
+    "Peg rule for capturing and coloring a rule."
+    [color what]
+    ~(/ (<- ,what) ,(partial paint color)))
+
+  (defn color-symbol
+    "Color a symbol only if it is a core library binding or special."
+    [text]
+    (def sym (symbol text))
+    (def should-color (or (specials sym) (core-env sym)))
+    (paint (if should-color :coresym :symbol) text))
+
+  ~{:ws (set " \t\r\f\n\0")
+    :readermac (set "';~,")
+    :symchars (+ (range "09" "AZ" "az" "\x80\xFF") (set "$%&*+-./:<=>?@^_|"))
+    :token (some :symchars)
+    :hex (range "09" "af" "AF")
+    :escape (* "\\" (+ (set "ntr0\"\\e") 
+                       (* "h" :hex :hex) 
+                       (error (constant "bad hex escape"))))
+
+    :comment ,(<-c :comment ~(* "#" (any (if-not (+ "\n" -1) 1))))
+
+    :symbol (/ (<- :token) ,color-symbol)
+    :keyword ,(<-c :keyword ~(* ":" (any :symchars)))
+    :constant ,(<-c :constant ~(+ "true" "false" "nil"))
+    :bytes (* "\"" (any (+ :escape (if-not "\"" 1))) "\"")
+    :string ,(<-c :string :bytes)
+    :buffer ,(<-c :string ~(* "@" :bytes))
+    :long-bytes {:delim (some "`")
+                 :open (capture :delim :n)
+                 :close (cmt (* (not (> -1 "`")) (-> :n) (<- :delim)) ,=)
+                 :main (drop (* :open (any (if-not :close 1)) :close))}
+    :long-string ,(<-c :string :long-bytes)
+    :long-buffer ,(<-c :string ~(* "@" :long-bytes))
+    :number (/ (cmt (<- :token) ,check-number) ,(partial paint :number))
+
+    :raw-value (+ :comment :constant :number :keyword
+                  :string :buffer :long-string :long-buffer
+                  :parray :barray :ptuple :btuple :struct :dict :symbol)
+
+    :value (* (? (<- (some (+ :ws :readermac)))) :raw-value (<- (any :ws)))
+    :root (any :value)
+    :root2 (any (* :value :value))
+    :ptuple (* (<- "(") :root (+ (<- ")") (error "")))
+    :btuple (* (<- "[") :root (+ (<- "]") (error "")))
+    :struct (* (<- "{") :root2 (+ (<- "}") (error "")))
+    :parray (* (<- "@") :ptuple)
+    :barray (* (<- "@") :btuple)
+    :dict (* (<-"@") :struct)
+
+    :main (+ (% :root) (error ""))})
+
+# Terminal syntax highlighting
+
+(def- terminal-colors
+  {:number 32
+   :keyword 33
+   :string 35
+   :coresym 31
+   :constant 34
+   :comment 36})
+
+(defn- terminal-paint
+  "Paint colors for ansi terminals"
+  [what str]
+  (def code (get terminal-colors what))
+  (if code (string "\e[" code "m" str "\e[0m") str))
+
+# HTML syntax highlighting
+
+(def- html-colors
+  {:number "j-number"
+   :keyword "j-keyword"
+   :string "j-string"
+   :coresym "j-coresym"
+   :constant "j-constant"
+   :comment "j-comment"
+   :line "j-line"})
+
+(def- escapes
+  {38 "&amp;"
+   60 "&lt;"
+   62 "&gt;"
+   34 "&quot;"
+   39 "&#39;"
+   47 "&#47;"})
+
+(def html-style
+  "Style tag to add to a page to highlight janet code"
+```
+<style type="text/css">
+.j-main { color: white; background: #111; font-size: 1.4em; }
+.j-number { color: #89dc76; }
+.j-keyword { color: #ffd866; }
+.j-string { color: #ab90f2; }
+.j-coresym { color: #ff6188; }
+.j-constant { color: #fc9867; }
+.j-comment { color: darkgray; }
+.j-line { color: gray; }
+</style>
+```)
+
+(def- html-boiler-prefix
+```<!DOCTYPE html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <title>title</title>
+  </head>
+  <body>
+  
+  </body>
+</html>
+```)
+
+(defn- html-escape
+  "Escape special characters for HTML encoding."
+  [str]
+  (def buf @"")
+  (loop [byte :in str]
+    (if-let [rep (get escapes byte)]
+      (buffer/push-string buf rep)
+      (buffer/push-byte buf byte)))
+  buf)
+
+(defn- html-paint
+  "Paint colors for HTML"
+  [what str]
+  (def color (get html-colors what))
+  (def escaped (html-escape str))
+  (if color
+    (string "<span class=\"" color "\">" escaped "</span>")
+    escaped))
+
+# Create Pegs
+
+(def- terminal-grammar (peg/compile (make-grammar terminal-paint)))
+(def- html-grammar (peg/compile (make-grammar html-paint)))
+
+# API
+
+(defn ansi
+  "Highlight janet source code ANSI Termianl escape colors."
+  [source]
+  (0 (peg/match terminal-grammar source)))
+
+(defn html
+  "Highlight janet source code and output HTML."
+  [source]
+  (string "<pre class=\"j-main\">"
+          (0 (peg/match html-grammar source))
+          "</pre>"))
+
+(defn html-file
+  "Highlight a janet file and print out a highlighted HTML version
+  of the file. Must provide a default title when creating the file."
+  [in-path out-path title &]
+  (default title in-path)
+  (def f (file/open in-path :r))
+  (def source (file/read f :all))
+  (file/close f)
+  (def markup (0 (peg/match html-grammar source)))
+  (def out (file/open out-path :w))
+  (file/write out
+              "<!doctype html><html><head><meta charset=\"UTF-8\">"
+              html-style
+              "<title>"
+              title
+              "</title></head>"
+              "<body class=\"j-main\"><pre>"
+              markup
+              "</pre></body></html>")
+  (file/close out))
+
+(defn ansi-file
+  "Highlight a janet file and print the highlighted output to stdout."
+  [in-path]
+  (def f (file/open in-path :r))
+  (def source (file/read f :all))
+  (file/close f)
+  (def markup (0 (peg/match terminal-grammar source)))
+  (print markup))