reorg

beautiful-racket-demo/basic-demo-2/colorer.rkt

@@ -1,22 +1,30 @@
 #lang br
 (require "lexer.rkt" brag/support)
-(provide color-basic)
+(provide basic-colorer)
 
-(define (color-basic port)
-  (define srcloc-tok (basic-lexer port))
-  (match srcloc-tok
-    [(? eof-object?) (values srcloc-tok 'eof #f #f #f)]
-    [else ; reverse-engineer with `match-define`
+(define (basic-colorer port)
+  (define next-char (peek-char port))
+  (define (handle-read-error exn)
+    (define exn-srclocs (exn:fail:read-srclocs exn))
+    (srcloc-token (token 'ERROR (string next-char)) (car exn-srclocs)))
+  (define srcloc-tok (with-handlers ([exn:fail:read? handle-read-error])
+                       (basic-lexer port)))
+  (cond 
+    [(eof-object? srcloc-tok) (values srcloc-tok 'eof #f #f #f)]
+    [else
      (match-define (srcloc-token (token-struct type val _ _ _ _ _)
                                  (srcloc _ _ _ pos span)) srcloc-tok)
-     (define (color cat [paren #f])
-       (values (or val "") cat paren pos (+ pos span)))
-     (match type
-       ['STRING (color 'string)]
-       ['REM (color 'comment)]
-       [else (match val
-               [(? number?) (color 'constant)]
-               [(? symbol?) (color 'symbol)]
-               ["(" (color 'parenthesis '|(|)]
-               [")" (color 'parenthesis '|)|)]
-               [else (color 'no-color)])])]))
+     (match-define (list cat paren)
+       (match type
+         ['STRING '(string #f)]
+         ['REM '(comment #f)]
+         ['ERROR '(error #f)]
+         [else (match val
+                 [(? number?)'(constant #f)]
+                 [(? symbol?) '(symbol #f)]
+                 ["(" '(parenthesis |(|)]
+                 [")" '(parenthesis |)|)]
+                 [else '(no-color #f)])]))
+     (values (or val "") cat paren pos (+ pos span))]))
+
+(apply-colorer basic-colorer "foo")

beautiful-racket-demo/basic-demo-2/elements.rkt

@@ -1,3 +1,3 @@
 #lang br
-(require "line.rkt" "go.rkt" "if.rkt" "expr.rkt" "for.rkt" "misc.rkt")
-(provide (all-from-out "line.rkt" "go.rkt" "if.rkt" "expr.rkt" "for.rkt" "misc.rkt"))
+(require "line.rkt" "go.rkt" "if.rkt" "expr.rkt" "misc.rkt")
+(provide (all-from-out "line.rkt" "go.rkt" "if.rkt" "expr.rkt" "misc.rkt"))

beautiful-racket-demo/basic-demo-2/for.rkt

@@ -1,30 +0,0 @@
-#lang br
-(require "misc.rkt" "line.rkt")
-(provide b-for b-next)
-
-(define thunk-table (make-hasheq))
-
-(define-macro-cases b-for
-  [(_ LOOP-ID START END) #'(b-for LOOP-ID START END 1)]
-  [(_ LOOP-ID START END STEP)
-   #'(b-let LOOP-ID (let/cc loop-cc
-                      (hash-set! thunk-table
-                                 'LOOP-ID
-                                 (λ ()
-                                   (define next-val (+ LOOP-ID STEP))
-                                   (if (next-val . in-closed-interval? . START END)
-                                       (loop-cc next-val)
-                                       (hash-remove! thunk-table 'LOOP-ID))))
-                      START))])
-
-(define (in-closed-interval? x start end)
-  (if (< start end)
-      (<= start x end)
-      (<= end x start)))
-
-(define-macro (b-next LOOP-ID)
-  #'(begin
-      (unless (hash-has-key? thunk-table 'LOOP-ID)
-        (raise-line-error "next without for"))
-      (define thunk (hash-ref thunk-table 'LOOP-ID))
-      (thunk)))

beautiful-racket-demo/basic-demo-2/go.rkt

@@ -1,6 +1,6 @@
 #lang br
-(require "struct.rkt" "line.rkt")
-(provide b-goto b-gosub b-return)
+(require "struct.rkt" "line.rkt" "misc.rkt")
+(provide b-goto b-gosub b-return b-for b-next)
 
 (define (b-goto num-expr)
   (raise (change-line-signal num-expr)))
@@ -16,4 +16,29 @@
   (unless (pair? return-stack)
     (raise-line-error "return without gosub"))
   (define top-return-k (pop! return-stack))
-  (top-return-k))
+  (top-return-k))
+
+(define thunk-table (make-hasheq))
+
+(define-macro-cases b-for
+  [(_ LOOP-ID START END) #'(b-for LOOP-ID START END 1)]
+  [(_ LOOP-ID START END STEP)
+   #'(b-let LOOP-ID (let/cc loop-cc
+                      (hash-set! thunk-table
+                                 'LOOP-ID
+                                 (λ ()
+                                   (define next-val (+ LOOP-ID STEP))
+                                   (if (next-val . in-closed-interval? . START END)
+                                       (loop-cc next-val)
+                                       (hash-remove! thunk-table 'LOOP-ID))))
+                      START))])
+
+(define (in-closed-interval? x start end)
+  ((if (< start end) <= >=) start x end))
+
+(define-macro (b-next LOOP-ID)
+  #'(begin
+      (unless (hash-has-key? thunk-table 'LOOP-ID)
+        (raise-line-error "next without for"))
+      (define thunk (hash-ref thunk-table 'LOOP-ID))
+      (thunk)))

beautiful-racket-demo/basic-demo-2/lexer.rkt

@@ -3,6 +3,9 @@
 
 (define-lex-abbrev digits (:+ (char-set "0123456789")))
 
+(define (handle-tok-error tok-ok? tok-name tok-value start-pos end-pos)
+  (token 'ERROR tok-value))
+
 (define basic-lexer
   (lexer-srcloc
    [(eof) (return-without-srcloc eof)]

beautiful-racket-demo/basic-demo-2/main.rkt

@@ -14,6 +14,6 @@
     (define (handle-query key default)
       (case key
         [(color-lexer)
-         (dynamic-require 'basic-demo-2/colorer 'color-basic)]
+         (dynamic-require 'basic-demo-2/colorer 'basic-colorer)]
         [else default]))
     handle-query)

beautiful-racket-demo/basic-demo-2/sample-for.rkt

@@ -1,8 +1,6 @@
 #lang basic-demo-2
 10 for a = 1 to 3
-20 print a
-21 for b = 103 to 101 step -1
-22 print b
+21 for b = 9 to 7 step -1
+22 print a ; b
 23 next b
-30 next a
-40 print "yay"
+30 next a