start new parser for txtadv

beautiful-racket/br/demo/txtadv.rkt

@@ -1,5 +1,5 @@
 #lang br
 
 (module reader br
-  (require "txtadv/reader.rkt")
-  (provide (all-from-out "txtadv/reader.rkt")))
+  (require "txtadv/reader0.rkt")
+  (provide (all-from-out "txtadv/reader0.rkt")))

beautiful-racket/br/demo/txtadv/expander.rkt

@@ -1,4 +1,5 @@
 #lang br
+(require (for-syntax racket/string))
 
 (provide define-verbs
          define-thing
@@ -20,7 +21,41 @@
 ;; ============================================================
 ;; Overall module:
 
-(define #'(module-begin (define-verbs _all-verbs _cmd ...)
+(define #'(module-begin _arg ...)
+  #'(#%module-begin
+     '_arg ...))
+
+(provide txtadv-program)
+(define-inverting #'(txtadv-program _verb-section ...)
+  #'(_verb-section ...))
+
+(provide verb-section)
+(define-inverting #'(verb-section _heading _verb-entry ...)
+  #'(define-verbs all-verbs
+        _verb-entry ...))
+
+(provide verb-entry)
+(define-inverting #'(verb-entry (_name0 _transitive0?) (_name _transitive?) ... _desc)
+  #`[_name0 #,@(if #'transitive0? #'(_) #'()) (= _name ...) _desc])
+
+(provide verb-name)
+(define-cases #'verb-name
+  ;; cases with literals go first, so they're not caught by wildcards
+  [#'(_ "," _id) #'(_id #f)]
+  [#'(_ "," _id _underscore) #'(_id #t)]
+  [#'(_ _id) #'(_id #f)]
+  [#'(_ _id _underscore) #'(_id #t)])
+
+(provide s-exp)
+(define #'(s-exp _sx)
+  #'_sx)
+
+(provide desc)
+(define #'(desc _d)
+  #'_d)
+
+
+#;(define #'(module-begin (define-verbs _all-verbs _cmd ...)
                         (define-everywhere _everywhere-actions _act ...)
                         _decl ...
                         _id)

beautiful-racket/br/demo/txtadv/footest.rkt

@@ -0,0 +1 @@
+#lang racket

beautiful-racket/br/demo/txtadv/main.rkt

@@ -1,5 +0,0 @@
-#lang br
-
-(module+ reader
-  (require "reader.rkt")
-  (provide (all-from-out "reader.rkt")))

beautiful-racket/br/demo/txtadv/parser.rkt

@@ -0,0 +1,15 @@
+#lang ragg
+
+txtadv-program : [verb-section] 
+
+verb-section : verb-heading verb-entry+
+
+verb-heading : "===VERBS==="
+
+verb-entry : verb-name+ desc
+
+verb-name : [","] ID ["_"]
+
+desc : s-exp
+
+s-exp : ID | STRING | "(" s-exp* ")"

beautiful-racket/br/demo/txtadv/reader.rkt

@@ -1,160 +1,6 @@
-#lang racket
-(require syntax/readerr)
+#lang br
 
-(provide (rename-out [txtadv-read-syntax read-syntax])
-         ;; added at the end to link syntax to colorer:
-         get-info)
-
-(define (txtadv-read-syntax src in)
-  (expect-section src in "VERBS")
-  (define verbs (in-section src in read-verb))
-  (expect-section src in "EVERYWHERE")
-  (define actions (in-section src in read-action))
-  (expect-section src in "THINGS")
-  (define things (in-section src in read-thing))
-  (expect-section src in "PLACES")
-  (define places (in-section src in read-place))
-  (datum->syntax
-   #f
-   `(module world br/demo/txtadv/expander
-      (define-verbs all-verbs
-        ,@verbs)
-      (define-everywhere everywhere-actions
-        ,actions)
-      ,@things
-      ,@places
-      ,(if (null? places)
-           (complain src in "no places defined")
-           (cadar places)))))
-
-(define (complain src in msg)
-  (define-values (line col pos) (port-next-location in))
-  (raise-read-error msg src line col pos 1))
-
-(define (skip-whitespace in)
-  (regexp-try-match #px"^\\s+" in))
-      
-(define (expect-section src in name)
-  (skip-whitespace in)
-  (unless (regexp-match-peek (pregexp (format "^===~a===\\s" name))
-                             in)
-    (complain src in (format "expected a ===~a=== section" name)))
-  (read-line in)
-  (read-line in))
-
-(define (in-section src in reader)
-  (skip-whitespace in)
-  (if (or (regexp-match-peek #rx"^===" in)
-          (eof-object? (peek-byte in)))
-      null
-      (cons (reader src in)
-            (in-section src in reader))))
-
-(define (in-defn src in reader)
-  (skip-whitespace in)
-  (if (or (regexp-match-peek #rx"^(===|---)" in)
-          (eof-object? (peek-byte in)))
-      null
-      (cons (reader src in)
-            (in-defn src in reader))))
-
-(define (read-name src in)
-  (if (regexp-match-peek #px"^[A-Za-z-]+(?=:$|\\s|[],])" in)
-      (read-syntax src in)
-      (complain src in "expected a name")))
-
-(define (read-name-sequence src in transitive)
-  (let loop ([names null] [transitive transitive])
-    (define s (read-name src in))
-    (define is-trans?
-      (cond
-       [(regexp-match-peek #rx"^ _" in)
-        (if (or (eq? transitive 'unknown)
-                (eq? transitive #t))
-            (begin
-              (read-char in)
-              (read-char in)
-              #t)
-            (begin
-              (read-char in)
-              (complain src in "unexpected underscore")))]
-       [else
-        (if (eq? transitive #t)
-            (complain src in "inconsistent transitivity")
-            #f)]))
-    (if (regexp-match-peek #rx"^, " in)
-        (begin
-          (read-char in)
-          (read-char in)
-          (loop (cons s names) is-trans?))
-        (values (reverse (cons s names)) is-trans?))))
-
-(define (read-verb src in)
-  (skip-whitespace in)
-  (define-values (names is-transitive?)
-    (read-name-sequence src in 'unknown))
-  (skip-whitespace in)
-  (define desc
-    (if (regexp-match-peek #rx"^\"" in)
-        (read-syntax src in)
-        (symbol->string (syntax-e (car names)))))
-  `[,(car names) 
-    ,@(if is-transitive? '(_) '())
-    (= ,@(cdr names))
-    ,desc])
-
-(define (read-action src in)
-  (skip-whitespace in)
-  (define name (read-name src in))
-  (define expr (read-syntax src in))
-  `[,name ,expr])
-
-(define (read-defn-name src in what)
-  (skip-whitespace in)
-  (unless (regexp-match-peek #px"^---[A-Za-z][A-Za-z0-9-]*---\\s"
-                             in)
-    (complain src in (format "expected a ~a definition of the form ---name---" what)))
-  (read-string 3 in)
-  (define-values (line col pos) (port-next-location in))
-  (define name-str (bytes->string/utf-8 (cadr (regexp-match #px"^(.*?)---\\s" in))))
-  (datum->syntax #f
-                 (string->symbol name-str)
-                 (vector src line col pos (string-length name-str))
-                 orig-props))
-(define orig-props (read-syntax 'src (open-input-string "orig")))
-
-(define (read-thing src in)
-  (define name (read-defn-name src in "thing"))
-  (define actions (in-defn src in read-action))
-  `(define-thing ,name
-     ,@actions))
-
-(define (read-place src in)
-  (define name (read-defn-name src in "place"))
-  (skip-whitespace in)
-  (define desc (if (regexp-match-peek #rx"^\"" in)
-                   (read-syntax src in)
-                   (complain src in "expected description string")))
-  (skip-whitespace in)
-  (unless (regexp-match-peek #rx"^[[]" in)
-    (complain src in "expected a square bracket to start a list of things for a place"))
-  (read-char in)
-  (define-values (things _) 
-    (if (regexp-match-peek #rx"^[]]" in)
-        (values null #f)
-        (read-name-sequence src in #f)))
-  (unless (regexp-match-peek #rx"^[]]" in)
-    (complain src in "expected a square bracket to end a list of things for a place"))
-  (read-char in)
-  (define actions (in-defn src in read-action))
-  `(define-place ,name ,desc ,things ,actions))
-
-;; DrRacket asks `get-info' for a 'color-lexer module:
-(require racket/runtime-path)
-(define-runtime-path color-lexer-path "color.rkt")
-(define (get-info in mod line col pos)
-  (lambda (key default)
-    (case key
-      [(color-lexer)
-       (dynamic-require color-lexer-path 'color-lexer)]
-      [else default])))
+(require br/reader-utils "parser.rkt" "tokenizer.rkt")
+  (define-read-and-read-syntax (source-path input-port)
+    #`(module txtadv-mod br/demo/txtadv/expander
+        #,(parse source-path (tokenize input-port))))

beautiful-racket/br/demo/txtadv/reader0.rkt

@@ -0,0 +1,160 @@
+#lang racket
+(require syntax/readerr)
+
+(provide (rename-out [txtadv-read-syntax read-syntax])
+         ;; added at the end to link syntax to colorer:
+         get-info)
+
+(define (txtadv-read-syntax src in)
+  (expect-section src in "VERBS")
+  (define verbs (in-section src in read-verb))
+  (expect-section src in "EVERYWHERE")
+  (define actions (in-section src in read-action))
+  (expect-section src in "THINGS")
+  (define things (in-section src in read-thing))
+  (expect-section src in "PLACES")
+  (define places (in-section src in read-place))
+  (datum->syntax
+   #f
+   `(module world br/demo/txtadv/expander
+      (define-verbs all-verbs
+        ,@verbs)
+      (define-everywhere everywhere-actions
+        ,actions)
+      ,@things
+      ,@places
+      ,(if (null? places)
+           (complain src in "no places defined")
+           (cadar places)))))
+
+(define (complain src in msg)
+  (define-values (line col pos) (port-next-location in))
+  (raise-read-error msg src line col pos 1))
+
+(define (skip-whitespace in)
+  (regexp-try-match #px"^\\s+" in))
+      
+(define (expect-section src in name)
+  (skip-whitespace in)
+  (unless (regexp-match-peek (pregexp (format "^===~a===\\s" name))
+                             in)
+    (complain src in (format "expected a ===~a=== section" name)))
+  (read-line in)
+  (read-line in))
+
+(define (in-section src in reader)
+  (skip-whitespace in)
+  (if (or (regexp-match-peek #rx"^===" in)
+          (eof-object? (peek-byte in)))
+      null
+      (cons (reader src in)
+            (in-section src in reader))))
+
+(define (in-defn src in reader)
+  (skip-whitespace in)
+  (if (or (regexp-match-peek #rx"^(===|---)" in)
+          (eof-object? (peek-byte in)))
+      null
+      (cons (reader src in)
+            (in-defn src in reader))))
+
+(define (read-name src in)
+  (if (regexp-match-peek #px"^[A-Za-z-]+(?=:$|\\s|[],])" in)
+      (read-syntax src in)
+      (complain src in "expected a name")))
+
+(define (read-name-sequence src in transitive)
+  (let loop ([names null] [transitive transitive])
+    (define s (read-name src in))
+    (define is-trans?
+      (cond
+       [(regexp-match-peek #rx"^ _" in)
+        (if (or (eq? transitive 'unknown)
+                (eq? transitive #t))
+            (begin
+              (read-char in)
+              (read-char in)
+              #t)
+            (begin
+              (read-char in)
+              (complain src in "unexpected underscore")))]
+       [else
+        (if (eq? transitive #t)
+            (complain src in "inconsistent transitivity")
+            #f)]))
+    (if (regexp-match-peek #rx"^, " in)
+        (begin
+          (read-char in)
+          (read-char in)
+          (loop (cons s names) is-trans?))
+        (values (reverse (cons s names)) is-trans?))))
+
+(define (read-verb src in)
+  (skip-whitespace in)
+  (define-values (names is-transitive?)
+    (read-name-sequence src in 'unknown))
+  (skip-whitespace in)
+  (define desc
+    (if (regexp-match-peek #rx"^\"" in)
+        (read-syntax src in)
+        (symbol->string (syntax-e (car names)))))
+  `[,(car names) 
+    ,@(if is-transitive? '(_) '())
+    (= ,@(cdr names))
+    ,desc])
+
+(define (read-action src in)
+  (skip-whitespace in)
+  (define name (read-name src in))
+  (define expr (read-syntax src in))
+  `[,name ,expr])
+
+(define (read-defn-name src in what)
+  (skip-whitespace in)
+  (unless (regexp-match-peek #px"^---[A-Za-z][A-Za-z0-9-]*---\\s"
+                             in)
+    (complain src in (format "expected a ~a definition of the form ---name---" what)))
+  (read-string 3 in)
+  (define-values (line col pos) (port-next-location in))
+  (define name-str (bytes->string/utf-8 (cadr (regexp-match #px"^(.*?)---\\s" in))))
+  (datum->syntax #f
+                 (string->symbol name-str)
+                 (vector src line col pos (string-length name-str))
+                 orig-props))
+(define orig-props (read-syntax 'src (open-input-string "orig")))
+
+(define (read-thing src in)
+  (define name (read-defn-name src in "thing"))
+  (define actions (in-defn src in read-action))
+  `(define-thing ,name
+     ,@actions))
+
+(define (read-place src in)
+  (define name (read-defn-name src in "place"))
+  (skip-whitespace in)
+  (define desc (if (regexp-match-peek #rx"^\"" in)
+                   (read-syntax src in)
+                   (complain src in "expected description string")))
+  (skip-whitespace in)
+  (unless (regexp-match-peek #rx"^[[]" in)
+    (complain src in "expected a square bracket to start a list of things for a place"))
+  (read-char in)
+  (define-values (things _) 
+    (if (regexp-match-peek #rx"^[]]" in)
+        (values null #f)
+        (read-name-sequence src in #f)))
+  (unless (regexp-match-peek #rx"^[]]" in)
+    (complain src in "expected a square bracket to end a list of things for a place"))
+  (read-char in)
+  (define actions (in-defn src in read-action))
+  `(define-place ,name ,desc ,things ,actions))
+
+;; DrRacket asks `get-info' for a 'color-lexer module:
+(require racket/runtime-path)
+(define-runtime-path color-lexer-path "color.rkt")
+(define (get-info in mod line col pos)
+  (lambda (key default)
+    (case key
+      [(color-lexer)
+       (dynamic-require color-lexer-path 'color-lexer)]
+      [else default])))

beautiful-racket/br/demo/txtadv/tokenizer.rkt

@@ -0,0 +1,23 @@
+#lang br
+(require parser-tools/lex parser-tools/lex-sre
+         ragg/support
+         racket/string)
+
+(provide tokenize)
+(define (tokenize input-port)
+  (define (next-token)
+    (define get-token
+      (lexer
+       [(eof) eof]
+       [(union
+         (seq "/*" (complement (seq any-string "*/" any-string)) "*/")
+         (seq "//" (repetition 1 +inf.0 (char-complement #\newline)) #\newline))
+        (token 'COMMENT lexeme #:skip? #t)]
+       [(union #\tab #\space #\newline) (get-token input-port)]
+       [(repetition 1 +inf.0 (union upper-case (char-set "="))) lexeme]
+       [(seq "\"" (complement (seq any-string "\"" any-string)) "\"") (token 'STRING lexeme)]
+       [(char-set ",_") lexeme]
+       [(repetition 1 +inf.0 (union alphabetic numeric (char-set "-.")))
+        (token 'ID (string->symbol lexeme))]))
+    (get-token input-port))  
+  next-token)

beautiful-racket/br/demo/txtadv/world.rkt

@@ -1,4 +1,5 @@
-#lang br/demo/txtadv
+#lang reader "reader.rkt"
+
 
 ===VERBS===
 
@@ -8,6 +9,8 @@ north, n
 south, s
  "go south"
 
+
+
 east, e
  "go east"
 
@@ -49,6 +52,7 @@ look, show
 inventory
  "check inventory"
 
+/*
 
 ===EVERYWHERE===
 
@@ -160,3 +164,5 @@ west
 
 out
   house-front
+
+*/

beautiful-racket/br/demo/txtadv/world0-test.rkt

@@ -0,0 +1,41 @@
+#lang at-exp racket
+(require rackunit)
+(require "world0.rkt")
+
+(check-equal? (with-output-to-string (λ _ (do-place)))
+              "You're standing in a meadow. There is a house to the north.\n")
+
+(define-syntax-rule (check-cmd? cmd result)
+  (check-equal? (with-output-to-string (λ _ (do-verb cmd))) result))
+
+(check-cmd?
+ "s"
+ "You're in a desert. There is nothing for miles around.\nThere is a cactus here.\nThere is a key here.\n")
+
+(check-cmd?
+ "get cactus"
+ "Ouch!\n")
+
+(check-cmd?
+ "get key"
+ "You now have the key.\n")
+
+(check-cmd?
+ "n"
+ "You're standing in a meadow. There is a house to the north.\n")
+
+(check-cmd?
+ "n"
+ "You are standing in front of a house.\nThere is a door here.\n")
+
+(check-cmd?
+ "open door"
+ "The door is now unlocked and open.\n")
+
+(check-cmd?
+ "enter"
+ "You're in the house.\nThere is a trophy here.\n")
+
+(check-cmd?
+ "get trophy"
+ "You win!\n")

beautiful-racket/br/demo/txtadv/world0.rkt

@@ -0,0 +1,162 @@
+#lang br/demo/txtadv
+
+===VERBS===
+
+north, n
+ "go north"
+
+south, s
+ "go south"
+
+east, e
+ "go east"
+
+west, w
+ "go west"
+
+up
+ "go up"
+
+down
+ "go down"
+
+in, enter
+ "enter"
+
+out, leave
+ "leave"
+
+get _, grab _, take _
+ "take"
+
+put _, drop _, leave _
+ "drop"
+
+open _, unlock _
+ "open"
+
+close _, lock _
+ "close"
+
+knock _
+
+quit, exit
+ "quit"
+
+look, show
+ "look"
+
+inventory
+ "check inventory"
+
+
+===EVERYWHERE===
+
+quit 
+ (begin
+  (printf "Bye!\n")
+  (exit))
+
+look 
+ (show-current-place)
+
+inventory 
+ (show-inventory)
+
+
+
+===THINGS===
+
+---cactus---
+get
+  "Ouch!"
+
+---door---
+open 
+  (if (have-thing? key)
+      (begin
+        (set-thing-state! door 'open)
+        "The door is now unlocked and open.")
+      "The door is locked.")
+
+close
+  (begin
+   (set-thing-state! door #f)
+   "The door is now closed.")
+
+knock
+  "No one is home."
+
+---key---
+
+get
+  (if (have-thing? key)
+      "You already have the key."
+      (begin
+        (take-thing! key)
+        "You now have the key."))
+
+put
+  (if (have-thing? key)
+      (begin
+        (drop-thing! key)
+        "You have dropped the key.")
+      "You don't have the key.")
+
+---trophy---
+
+get
+  (begin
+   (take-thing! trophy)
+   "You win!")
+
+
+===PLACES===
+
+---meadow---
+"You're standing in a meadow. There is a house to the north."
+[]
+
+north
+ house-front
+
+south
+ desert
+
+
+---house-front---
+"You are standing in front of a house."
+[door]
+
+in 
+  (if (eq? (thing-state door) 'open)
+      room
+      "The door is not open.")
+
+south
+  meadow
+
+
+---desert---
+"You're in a desert. There is nothing for miles around."
+[cactus, key]
+
+north
+  meadow
+
+south
+  desert
+
+east
+  desert
+
+west
+  desert
+
+
+---room---
+"You're in the house."
+[trophy]
+
+out
+  house-front