beautiful-racket/beautiful-racket-demo/txtadv-demo/6-color/reader.rkt

#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 "txtadv.rkt"
      (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])))