refactor

beautiful-racket-demo/basic-demo/expander.rkt

@@ -3,9 +3,11 @@
          (matching-identifiers-out #rx"^b-" (all-defined-out)))
 
 (define-macro (b-module-begin (b-program LINE ...))
-  (with-pattern ([(LINE-NUM ...)
-                  (filter-stx-prop 'b-line-number (stx-flatten #'(LINE ...)))]
-                 [(LINE-ID ...) (prefix-ids "line-" #'(LINE-NUM ...))])
+  (with-pattern
+      ([(LINE-NUM ...)
+        (filter-stx-prop 'b-line-number
+                         (stx-flatten #'(LINE ...)))]
+       [(LINE-ID ...) (prefix-ids "line-" #'(LINE-NUM ...))])
     #'(#%module-begin
        LINE ...
        (define line-table
@@ -13,9 +15,10 @@
        (run line-table))))
 
 (define-macro (b-line LINE-NUMBER STATEMENT ...)
-  (with-pattern ([LINE-NUMBER-ID (prefix-id "line-" #'LINE-NUMBER
-                                            #:source #'LINE-NUMBER)]
-                 [ORIG-LOC caller-stx])
+  (with-pattern
+      ([LINE-NUMBER-ID (prefix-id "line-" #'LINE-NUMBER
+                                  #:source #'LINE-NUMBER)]
+       [ORIG-LOC caller-stx])
     (syntax/loc caller-stx
       (define (LINE-NUMBER-ID #:srcloc? [srcloc #f])
         (if srcloc
@@ -31,24 +34,28 @@
 (struct $program-end-signal ())
 (define (b-end) (raise ($program-end-signal)))
 
-(struct $change-line-signal (num))
+(struct $change-line-signal (val))
 (define (b-goto expr) (raise ($change-line-signal expr)))
 
 (define-exn line-not-found exn:fail)
 
 (define (run line-table)
-  (define line-vec (list->vector (sort (hash-keys line-table) <)))
+  (define line-vec
+    (list->vector (sort (hash-keys line-table) <)))
   (with-handlers ([$program-end-signal? void])
     (for/fold ([line-idx 0])
               ([i (in-naturals)])
       (unless (< line-idx (vector-length line-vec)) (b-end))
       (define line-num (vector-ref line-vec line-idx))
       (define line-proc (hash-ref line-table line-num))
-      (with-handlers ([$change-line-signal?
-                       (λ (cls)
-                         (or
-                          (and (exact-positive-integer? ($change-line-signal-num cls))
-                               (vector-member ($change-line-signal-num cls) line-vec))
-                          (raise-line-not-found (line-proc #:srcloc? #t))))])
+      (with-handlers
+          ([$change-line-signal?
+            (λ (cls)
+              (define clsv ($change-line-signal-val cls))
+              (or
+               (and (exact-positive-integer? clsv)
+                    (vector-member clsv line-vec))
+               (raise-line-not-found
+                (line-proc #:srcloc? #t))))])
         (line-proc)
         (add1 line-idx)))))

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

@@ -0,0 +1,21 @@
+#lang br
+(require brag/support racket/contract)
+
+(define basic-lexer
+  (lexer-srcloc
+   [(eof) eof]
+   [whitespace (token lexeme #:skip? #t)]
+   [(from/to "rem" "\n") (token 'REM lexeme)]
+   [(:or "print" "goto" "end" "+" ":") lexeme]
+   [(:+ numeric) (token 'INTEGER (string->number lexeme))]
+   [(:or (:seq (:+ numeric) ".")
+         (:seq (:* numeric) "." (:+ numeric)))
+    (token 'DECIMAL (string->number lexeme))]
+   [(from/to "\"" "\"")
+    (token 'STRING (trim-ends "\"" lexeme "\""))]))
+
+(provide
+ (contract-out
+  [basic-lexer
+   (input-port? . -> .
+                (or/c eof-object? string? srcloc-token?))]))

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

@@ -1,15 +1,16 @@
 #lang br/quicklang
-(require "parser.rkt" "tokenizer.rkt" brag/support)
+(require "parser.rkt" "tokenizer.rkt")
 
 (module+ reader (provide read-syntax))
 
 (define (read-syntax path port)
-  (define-values (line col pos) (port-next-location port))
-  (define port+newline (input-port-append #f port (open-input-string "\n")))
+  (define-values (pline pcol ppos) (port-next-location port))
+  (define port+newline
+    (input-port-append #f port (open-input-string "\n")))
   (port-count-lines! port+newline)
-  (set-port-next-location! port+newline line col pos)
-  (with-handlers ([exn:fail:parsing? (λ (exn) (displayln "Sorry!") (raise exn))])
-    (define parse-tree (parse path (make-tokenizer port+newline)))
-    (strip-bindings
-     #`(module basic-mod basic-demo/expander
-         #,parse-tree))))
+  (set-port-next-location! port+newline pline pcol ppos)
+  (define parse-tree
+    (parse path (make-tokenizer port+newline path)))
+  (strip-bindings
+   #`(module basic-mod basic-demo/expander
+       #,parse-tree)))

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

@@ -1,8 +1,8 @@
 #lang basic-demo
-30 rem print "statement ignored"
-40 end
+30 rem print "ignored"
 50 print "never gets here"
-60 print "two" : print 1.2 + 1.8
+40 end
+60 print "three" : print 2 + 2
 70 goto 11 + 10.5 + 8.5
 10 print "one"
 20 print : goto 60 : end

beautiful-racket-demo/basic-demo/tokenizer.rkt

@@ -1,20 +1,14 @@
 #lang br
-(require brag/support)
-(provide (all-defined-out))
+(require "lexer.rkt" brag/support racket/contract)
 
-(define basic-lexer
-  (lexer-srcloc
-   [(eof) eof]
-   [whitespace (token lexeme #:skip? #t)]
-   [(from/to "rem" "\n") (token 'REM lexeme)]
-   [(:or "print" "goto" "end" "+" ":") lexeme]
-   [(:+ numeric) (token 'INTEGER (string->number lexeme))]
-   [(:or (:seq (:+ numeric) ".")
-         (:seq (:* numeric) "." (:+ numeric)))
-    (token 'DECIMAL (string->number lexeme))]
-   [(from/to "\"" "\"") (token 'STRING (trim-ends  "\"" lexeme "\""))]))
-
-(define (make-tokenizer ip)
+(define (make-tokenizer ip [path #f])
   (port-count-lines! ip)
+  (file-path path)
   (define (next-token) (basic-lexer ip))
-  next-token)
+  next-token)
+
+(provide
+ (contract-out
+  [make-tokenizer
+   ((input-port?) (path?) . ->* .
+                  (-> (or/c eof-object? string? srcloc-token?)))]))