pollen/pollen/mode.rkt

#lang racket/base

#|
Implements the pollen/mode metalanguage.
Problem is that scribble/reader, and the at-exp metalanguage, changed after 6.1.
So this file
a) adapts the at-exp metalang from 6.2
b) incorporates the scribble/reader from 6.2
so that everything will work correctly in 6.0.

Note that pollen/mode uses default-command-char, NOT (setup:command-char),
because doing so would create a loading loop if pollen/mode were used in "pollen.rkt" (which is a likely place to use it)
Intractable problem; unavoidable limitation.
|#


(module* runtime-config racket/base
  (provide configure)
  
  (require (only-in (submod ".." at-reader) make-at-readtable))
  
  (define (configure data)
    (define old-read (current-read-interaction))
    (define (new-read src in)
      (parameterize ([current-readtable (make-at-readtable #:readtable (current-readtable))])
        (old-read src in)))
    (current-read-interaction new-read)))

(module* language-info racket/base
  (provide get-language-info)
  
  (require racket/match)
  
  (define (get-language-info data)
    (define other-get-info
      (match data
        [(vector mod sym data2)
         ((dynamic-require mod sym) data2)]
        [_ (λ (key default) default)]))
    (λ (key default)
      (case key
        [(configure-runtime)
         (define config-vec '#[(submod pollen/mode runtime-config) configure #f])
         (define other-config (other-get-info key default))
         (cond [(list? other-config) (cons config-vec other-config)]
               [else (list config-vec)])]
        [else (other-get-info key default)]))))

(module* reader racket/base
  (require syntax/module-reader
           (only-in (submod ".." at-reader) make-at-readtable))
  
  (provide (rename-out [at-read read]
                       [at-read-syntax read-syntax]
                       [at-get-info get-info]))
  
  (define (wrap-reader p)
    (λ args
      (parameterize ([current-readtable (make-at-readtable #:datum-readtable 'dynamic
                                                           #:command-readtable 'dynamic
                                                           #:command-char (dynamic-require 'pollen/setup 'default-command-char))])
        (apply p args))))
  
  (define-values (at-read at-read-syntax at-get-info)
    (make-meta-reader
     'pollen/mode
     "language path"
     (λ (bstr)
       (let* ([str (bytes->string/latin-1 bstr)]
              [sym (string->symbol str)])
         (and (module-path? sym)
              (vector
               ;; try submod first:
               `(submod ,sym reader)
               ;; fall back to /lang/reader:
               (string->symbol (string-append str "/lang/reader"))))))
     wrap-reader
     (λ (orig-read-syntax)
       (define read-syntax (wrap-reader orig-read-syntax))
       (λ args
         (define stx (apply read-syntax args))
         (define old-prop (syntax-property stx 'module-language))
         (define new-prop `#((submod pollen/mode language-info) get-language-info ,old-prop))
         (syntax-property stx 'module-language new-prop)))
     (λ (proc)
       (λ (key defval)
         (define (fallback) (if proc (proc key defval) defval))
         (define (try-dynamic-require mod export)
           (or (with-handlers ([exn:fail? (λ (x) #f)])
                 (dynamic-require mod export))
               (fallback)))
         (case key
           [(color-lexer)
            (define lexer-maker (dynamic-require 'syntax-color/scribble-lexer 'make-scribble-lexer (λ () #f)))
            (if lexer-maker
                (lexer-maker #:command-char #\◊)
                (fallback))]
           [(drracket:indentation)
            (dynamic-require 'pollen/private/mode-indentation 'determine-spaces)]
           [else (fallback)]))))))

(module at-reader racket/base
  ;; ============================================================================
  ;; Implements the @-reader macro for embedding text in Racket code.
  
  (require syntax/readerr)

  ;; ----------------------------------------------------------------------------
  ;; utilities for syntax specifications below

  ;; regexps
  (define (px . args)
    (let* ([args (let loop ([xs args])
                   (if (list? xs) (apply append (map loop xs)) (list xs)))]
           [args (map (lambda (x)
                        (cond [(bytes? x) x]
                              [(string? x) (string->bytes/utf-8 x)]
                              [(char? x) (regexp-quote (string->bytes/utf-8 (string x)))]
                              [(not x) #""]
                              [else (internal-error 'px)]))
                      args)])
      (byte-pregexp (apply bytes-append args))))
  (define (^px . args) (px #"^" args))

  ;; reverses a byte string visually
  (define reverse-bytes
    (let ([pairs (let ([xs (bytes->list #"([{<")]
                       [ys (bytes->list #")]}>")])
                   (append (map cons xs ys) (map cons ys xs)))])
      (define (rev-byte b)
        (cond [(assq b pairs) => cdr]
              [else b]))
      (lambda (bs) (list->bytes (map rev-byte (reverse (bytes->list bs)))))))

  ;; ----------------------------------------------------------------------------
  ;; syntax

  ;; basic syntax customization
  (define ch:command      #\@)
  (define ch:comment      #\;)
  (define ch:expr-escape  #\|)
  (define ch:datums-begin #\[)
  (define ch:datums-end   #\])
  (define ch:lines-begin  #\{)
  (define ch:lines-end    #\})

  (define str:lines-begin* #"(\\|[^a-zA-Z0-9 \t\r\n\f@\\\177-\377{]*)\\{")
  (define str:end-of-line  "[ \t]*\r?\n[ \t]*") ; eat spaces on the next line

  ;; regexps based on the above (more in make-dispatcher)
  (define re:whitespaces   (^px "\\s+"))
  (define re:comment-start (^px ch:comment))
  (define re:comment-line  (^px "[^\n]*(?:\n|$)[ \t]*")) ; like tex's `%'
  (define re:expr-escape   (^px ch:expr-escape))
  (define re:datums-begin  (^px ch:datums-begin))
  (define re:datums-end    (^px ch:datums-end))
  (define re:lines-begin   (^px ch:lines-begin))
  (define re:lines-begin*  (^px str:lines-begin*))
  (define re:lines-end     (^px ch:lines-end))
  (define re:end-of-line   (^px str:end-of-line))

  ;; ----------------------------------------------------------------------------
  ;; utilities

  (define (internal-error label)
    (error 'scribble-reader "internal error [~a]" label))

  ;; like `regexp-try-match', without extras; the regexp that is used
  ;; must be anchored -- nothing is dropped
  (define (*regexp-match-peek-positions pattern input-port)
    #; ; sanity checks, not needed unless this file is edited
    (unless (and (byte-regexp? pattern)
                 (regexp-match? #rx#"^\\^" (object-name pattern)))
      (internal-error 'invalid-bregexp))
    (regexp-match-peek-positions pattern input-port))
  ;; the following doesn't work -- must peek first
  ;; (define (*regexp-match-positions pattern input-port)
  ;;   #; ; sanity checks, not needed unless this file is edited
  ;;   (unless (and (byte-regexp? pattern)
  ;;                (regexp-match? #rx#"^\\^" (object-name pattern)))
  ;;     (internal-error 'invalid-bregexp))
  ;;   (regexp-match-peek-positions pattern input-port))
  (define (*regexp-match pattern input-port)
    (let ([m (*regexp-match-peek-positions pattern input-port)])
      (and m (let ([s (read-bytes (cdar m) input-port)])
               (cons s (map (lambda (p) (and p (subbytes s (car p) (cdr p))))
                            (cdr m)))))))
  ;; like regexp-match, but returns the whole match
  (define (*regexp-match1 pattern input-port)
    (let ([m (*regexp-match-peek-positions pattern input-port)])
      (and m (read-bytes (cdar m) input-port))))

  ;; Utility for readtable-based caches
  (define (readtable-cached fun)
    (let ([cache (make-weak-hasheq)])
      (letrec ([readtable-cached
                (case-lambda
                  [(rt) (hash-ref cache rt
                                  (lambda ()
                                    (let ([r (fun rt)])
                                      (hash-set! cache rt r)
                                      r)))]
                  [() (readtable-cached (current-readtable))])])
        readtable-cached)))

  ;; Skips whitespace characters, sensitive to the current readtable's
  ;; definition of whitespace; optimizes common spaces when possible
  (define skip-whitespace
    (let* ([plain-readtables  (make-weak-hasheq)]
           [plain-spaces      " \t\n\r\f"]
           [plain-spaces-list (string->list " \t\n\r\f")]
           [plain-spaces-re   (^px "[" plain-spaces "]*")])
      (define (skip-plain-spaces port)
        ;; hack: according to the specs, this might consume more characters
        ;; than needed, but it works fine with a simple <ch>* regexp (because
        ;; it can always match an empty string)
        (*regexp-match-peek-positions plain-spaces-re port))
      (define (whitespace? ch rt)
        (if rt
            (let-values ([(like-ch/sym _1 _2) (readtable-mapping rt ch)])
              ;; if like-ch/sym is whitespace, then ch is whitespace
              (and (char? like-ch/sym) (char-whitespace? like-ch/sym)))
            ;; `char-whitespace?' is fine for the default readtable
            (char-whitespace? ch)))
      (define plain-readtable?
        (readtable-cached
         (lambda (rt)
           (andmap (lambda (ch) (whitespace? ch rt)) plain-spaces-list))))
      (lambda (port)
        (let* ([rt (current-readtable)] [plain? (plain-readtable? rt)])
          (let loop ()
            (when plain? (skip-plain-spaces port))
            (let ([ch (peek-char port)])
              (unless (eof-object? ch)
                (when (whitespace? ch rt) (read-char port) (loop)))))))))

  ;; make n spaces, cached for n
  (define make-spaces
    (let ([t (make-hasheq)])
      (lambda (n)
        (hash-ref t n
                  (lambda ()
                    (let ([s (make-string n #\space)])
                      (hash-set! t n s) s))))))

  (define (bytes-width bs start)
    (let ([len (bytes-length bs)])
      (if (regexp-match? #rx"^ *$" bs start)
          (- (bytes-length bs) start)
          (let loop ([i start] [w 0])
            (if (= i len)
                w
                (loop (add1 i)
                      (+ w (if (eq? 9 (bytes-ref bs i)) (- 8 (modulo w 8)) 1))))))))

  ;; A syntax object that has the "original?" property:
  (define orig-stx (read-syntax #f (open-input-string "dummy")))

  ;; ----------------------------------------------------------------------------
  ;; main reader function for @ constructs

  (define (dispatcher char inp source-name line-num col-num position
                      start-inside? command-readtable ch:command
                      re:command re:line-item* re:line-item
                      re:line-item-no-nests datum-readtable
                      syntax-post-processor)

    (define (read-error line col pos msg . xs)
      (let* ([eof? (and (eq? 'eof msg) (pair? xs))]
             [msg  (apply format (if eof? xs (cons msg xs)))])
        ((if eof? raise-read-error raise-read-eof-error)
         msg (or source-name (object-name inp)) line col pos (span-from pos))))
    (define (read-error* . xs)
      (apply read-error line-num col-num position xs))

    (define (read-stx) (read-syntax/recursive source-name inp))
    (define (read-stx/rt rt) (read-syntax/recursive source-name inp #f rt))
    ;; use this to avoid placeholders
    (define (read-stx*)
      ;; (read-syntax/recursive source-name inp #f (current-readtable) #f)
      (read-syntax source-name inp))

    (define (*match  rx) (*regexp-match rx inp))
    (define (*match1 rx) (*regexp-match1 rx inp))
    ;; (define (*skip   rx) (*regexp-match-positions rx inp)) ; <- see above
    (define (*skip   rx) (*regexp-match1 rx inp))
    (define (*peek   rx) (*regexp-match-peek-positions rx inp))

    (define (span-from start)
      (and start (let-values ([(line col pos) (port-next-location inp)])
                   (- pos start))))

    (define (read-delimited-list begin-re end-re end-ch)
      (let-values ([(line col pos) (port-next-location inp)])
        (and (*skip begin-re)
             (let loop ([r '()])
               (skip-whitespace inp)
               (if (*skip end-re)
                   (reverse r)
                   (let ([x (read-stx)])
                     (if (eof-object? x)
                         (read-error line col pos 'eof "expected a '~a'" end-ch)
                         (loop (if (special-comment? x) r (cons x r))))))))))

    ;; identifies newlines in text
    (define (eol-syntax? x)
      (let ([p (and (syntax? x) (syntax-property x 'scribble))])
        (and (pair? p) (eq? 'newline (car p)))))

    ;; gets an accumulated (reversed) list of syntaxes and column markers, and
    ;; sorts things out (remove prefix and suffix newlines, adds indentation if
    ;; needed)
    (define (done-items xs)
      ;; a column marker is either a non-negative integer N (saying the following
      ;; code came from at column N), or a negative integer -N (saying that the
      ;; following code came from column N but no need to add indentation at this
      ;; point because it is at the openning of a {...}); `get-lines*' is careful
      ;; not to include column markers before a newline or the end of the text,
      ;; and a -N marker can only come from the beginning of the text (and it's
      ;; never there if the text began with a newline)
      (if (andmap eol-syntax? xs)
          ;; nothing to do
          (reverse xs)
          (let ([mincol (let loop ([xs xs] [m #f])
                          (if (null? xs)
                              m
                              (let ([x (car xs)])
                                (loop (cdr xs)
                                      (if (integer? x)
                                          (let ([x (abs x)]) (if (and m (< m x)) m x))
                                          m)))))])
            (let loop ([xs (if (and (not start-inside?) (eol-syntax? (car xs)))
                               (cdr xs) ; trim last eol
                               xs)]
                       [r '()])
              (if (or (null? xs)
                      (and (not start-inside?)
                           ;; trim first eol
                           (null? (cdr xs)) (eol-syntax? (car xs))))
                  r
                  (loop
                   (cdr xs)
                   (let ([x (car xs)])
                     (cond [(integer? x)
                            (if (or (< x 0) (= x mincol))
                                r ; no indentation marker, or zero indentation
                                (let ([eol (cadr xs)]
                                      [spaces (make-spaces (- x mincol))])
                                  ;; markers always follow end-of-lines
                                  (unless (eol-syntax? eol)
                                    (internal-error 'done-items))
                                  (cons (syntax-property
                                         (datum->syntax eol spaces eol)
                                         'scribble 'indentation)
                                        r)))]
                           ;; can have special comment values from "@||"
                           [(special-comment? x) r]
                           [else (cons x r)]))))))))

    ;; cons stx (new syntax) to the list of stxs, merging it if both are
    ;; strings, except for newline markers
    (define (maybe-merge stx stxs)
      (let* ([2nd  (and (syntax? stx) (syntax-e stx))]
             [stx0 (and (pair? stxs) (car stxs))]
             [1st  (and (syntax? stx0) (syntax-e stx0))])
        (if (and (string? 1st) (not (eol-syntax? stx0))
                 (string? 2nd) (not (eol-syntax? stx)))
            (cons (datum->syntax stx0
                                 (string-append 1st 2nd)
                                 (vector (syntax-source stx0)
                                         (syntax-line   stx0)
                                         (syntax-column stx0)
                                         (syntax-position stx0)
                                         ;; this is called right after reading stx
                                         (span-from (syntax-position stx0)))
                                 stx0)
                  (cdr stxs))
            (cons stx stxs))))

    ;; helper for `get-lines*' drop a column marker if the previous item was also
    ;; a newline (or the beginning)
    (define (maybe-drop-marker r)
      (if (and (pair? r) (integer? (car r))
               (or (null? (cdr r)) (eol-syntax? (cadr r))))
          (cdr r)
          r))

    (define (get-lines* re:begin re:end re:cmd-pfx re:item end-token)
      ;; re:begin, re:end, end-token can be false if start-inside? is #t;
      ;; re:cmd-pfx is a regexp when we do sub-@-reads only after a prefix
      (let loop ([lvl 0]
                 [r (let-values ([(l c p) (port-next-location inp)])
                      ;; marker for the beginning of the text
                      (if c (list (- c)) '()))])
        ;; this loop collects lines etc for the body, and also puts in column
        ;; markers (integers) after newlines -- the result is handed off to
        ;; `done-items' to finish the job
        (define-values (line col pos) (port-next-location inp))
        (define (make-stx sexpr)
          (datum->syntax #f
                         (if (bytes? sexpr) (bytes->string/utf-8 sexpr) sexpr)
                         (vector source-name line col pos (span-from pos))
                         orig-stx))
        (cond
          [(and re:begin (*match1 re:begin))
           => (lambda (m) (loop (add1 lvl) (maybe-merge (make-stx m) r)))]
          [(and re:end (*match1 re:end))
           => (lambda (m)
                (if (and (zero? lvl) (not start-inside?))
                    ;; drop a marker if it's after a last eol item
                    (done-items (maybe-drop-marker r))
                    (loop (sub1 lvl) (maybe-merge (make-stx m) r))))]
          [(*match1 re:end-of-line)
           => (lambda (m)
                (let ([n (car (regexp-match-positions #rx#"\n" m))])
                  (loop lvl (list* ; no merge needed
                             (bytes-width m (cdr n))
                             (syntax-property
                              (make-stx "\n")
                              'scribble `(newline ,(bytes->string/utf-8 m)))
                             (maybe-drop-marker r)))))]
          [(if re:cmd-pfx
               (and (*skip re:cmd-pfx) (*peek re:command))
               (*peek re:command))
           ;; read the next value
           => (lambda (m)
                (define x (cond [(cadr m)
                                 ;; the command is a string escape, use
                                 ;; `read-stx*' to not get a placeholder, so we
                                 ;; can merge the string to others
                                 (read-stx*)]
                                [(caddr m)
                                 ;; it's an expression escape, get multiple
                                 ;; expressions and put them all here
                                 (read-bytes (caaddr m) inp)
                                 (get-escape-expr #f)]
                                [else (read-stx)])) ; otherwise: a plain sub-read
                (loop lvl (cond [(eof-object? x)
                                 ;; shouldn't happen -- the sub-read would
                                 ;; raise an error
                                 (internal-error 'get-lines*-sub-read)]
                                ;; throw away comments
                                [(special-comment? x) r]
                                ;; escaped expressions: no merge, and add a
                                ;; comment to prevent merges with later stuff
                                [(pair? x)
                                 `(,(make-special-comment #f) ,@(reverse x) ,@r)]
                                [(null? x) (cons (make-special-comment #f) r)]
                                [else (maybe-merge x r)])))]
          ;; must be last, since it will always succeed with 1 char
          [(*peek re:item) ; don't read: regexp grabs the following text
           => (lambda (m)
                (loop lvl
                      (maybe-merge (make-stx (read-bytes (cdadr m) inp)) r)))]
          [(*peek #rx#"^$")
           (if end-token
               (read-error* 'eof "missing closing `~a'" end-token)
               (done-items r))]
          [else (internal-error 'get-lines*)])))

    (define (get-lines)
      (cond [(*skip re:lines-begin) (get-lines* re:lines-begin re:lines-end #f
                                                re:line-item ch:lines-end)]
            [(*match re:lines-begin*)
             => (lambda (m)
                  (let* ([bgn (car m)]
                         [end  (reverse-bytes bgn)]
                         [bgn* (regexp-quote bgn)]
                         [end* (regexp-quote end)]
                         [cmd-pfx* (regexp-quote (cadr m))])
                    (get-lines* (^px bgn*) (^px end*)
                                (^px cmd-pfx* "(?=" ch:command ")")
                                (re:line-item* bgn* end* cmd-pfx*)
                                end)))]
            [else #f]))

    (define (get-datums)
      (parameterize ([current-readtable datum-readtable])
        (read-delimited-list re:datums-begin re:datums-end ch:datums-end)))

    (define (get-escape-expr single?)
      ;; single? means expect just one expression (or none, which is returned as
      ;; a special-comment)
      (let ([get (lambda ()
                   (parameterize ([current-readtable command-readtable])
                     (read-delimited-list re:expr-escape re:expr-escape
                                          ch:expr-escape)))])
        (if single?
            (let*-values ([(line col pos) (port-next-location inp)]
                          [(xs) (get)])
              (cond [(not xs) xs]
                    [(or (null? xs) (not (null? (cdr xs))))
                     (read-error line col pos
                                 "a ~a|...| form in Racket mode must have ~a"
                                 ch:command
                                 "exactly one escaped expression")]
                    [else (car xs)]))
            (get))))

    ;; called only when we must see a command in the input
    (define (get-command)
      (let ([cmd (read-stx/rt command-readtable)])
        (cond [(special-comment? cmd)
               (read-error* "expecting a command expression, got a comment")]
              [(eof-object? cmd)
               (read-error* 'eof "missing command")]
              ;; we have a command: adjust its location to include the dispatch
              ;; character
              [else
               ;; (datum->syntax #f (syntax-e cmd)
               ;;   (vector (syntax-source cmd)
               ;;           (syntax-line cmd)
               ;;           (cond [(syntax-column cmd) => sub1] [else #f])
               ;;           (cond [(syntax-position cmd) => sub1] [else #f])
               ;;           (cond [(syntax-span cmd) => add1] [else #f]))
               ;;   orig-stx)
               ;; The reasoning for the above is that in `@foo' the `@' is part
               ;; of the syntax of the identifier, in a similar way to including
               ;; the double quotes in the position information for a string
               ;; syntax or the backslash in a mzscheme \foo identifier.  Another
               ;; feature of this is that there needs to be some way to know what
               ;; was the actual source of some syntax.  However, this is
               ;; problematic in two ways: (a) it can be confusing that
               ;; highlighting an identifier highlights the `@' too, and more
               ;; importantly, it makes `@|foo|' be treated differently than
               ;; `@foo'.  So we'll try to not do this adjusting.
               cmd])))

    (define (get-rprefixes) ; return punctuation prefixes in reverse
      (let loop ([r '()])
        (let-values ([(line col pos) (port-next-location inp)])
          (cond [(*match1 #rx#"^#?(?:'|`|,@?)")
                 => (lambda (m)
                      (let ([sym (cond [(assoc m '([#"'"   quote]
                                                   [#"`"   quasiquote]
                                                   [#","   unquote]
                                                   [#",@"  unquote-splicing]
                                                   [#"#'"  syntax]
                                                   [#"#`"  quasisyntax]
                                                   [#"#,"  unsyntax]
                                                   [#"#,@" unsyntax-splicing]))
                                        => cadr]
                                       [else (internal-error 'get-rprefixes)])])
                        (loop (cons (datum->syntax #f sym
                                                   (vector source-name line col
                                                           pos (span-from pos))
                                                   orig-stx)
                                    r))))]
                [(*skip re:whitespaces)
                 (read-error* "unexpected whitespace after ~a" ch:command)]
                [else r]))))

    (cond
      [start-inside?
       (datum->syntax #f (get-lines* #f #f #f re:line-item-no-nests #f)
                      (vector source-name line-num col-num position (span-from position))
                      orig-stx)]
      [(*skip re:whitespaces)
       (read-error* "unexpected whitespace after ~a" ch:command)]
      [(*skip re:comment-start)
       (unless (get-lines) (*skip re:comment-line))
       (make-special-comment #f)]
      [else
       (let*-values
           ([(rpfxs) (get-rprefixes)]
            [(cmd datums lines)
             (cond [(get-lines)
                    ;; try get-lines first -- so @|{...}| is not used as a simple
                    ;; expression escape, same for get-datums
                    => (lambda (lines) (values #f #f lines))]
                   [(get-datums)
                    => (lambda (datums) (values #f datums (get-lines)))]
                   [(get-escape-expr #t) => (lambda (expr) (values expr #f #f))]
                   [else (values (get-command) (get-datums) (get-lines))])]
            [(stx) (and (or datums lines)
                        (append (or datums '()) (or lines '())))]
            [(stx) (or (and cmd stx (cons cmd stx)) ; all parts
                       stx  ; no cmd part => just a parenthesized expression
                       cmd  ; no datums/lines => simple expression (no parens)
                       ;; impossible: either we saw []s or {}s, or we read a
                       ;; racket expression
                       (internal-error 'dispatcher))]
            [(stx) (let ([ds (and datums (length datums))]
                         [ls (and lines  (length lines))])
                     (syntax-property
                      (if (syntax? stx)
                          stx
                          (datum->syntax #f stx
                                         (vector source-name line-num col-num position
                                                 (span-from position))
                                         orig-stx))
                      'scribble (list 'form ds ls)))]
            [(stx) (syntax-post-processor stx)]
            [(stx)
             ;; wrap the prefixes around the result
             (let loop ([rpfxs rpfxs] [stx stx])
               (if (null? rpfxs)
                   stx
                   (loop (cdr rpfxs) (list (car rpfxs) stx))))])
         (datum->syntax #f stx (vector source-name line-num col-num position
                                       (span-from position))
                        orig-stx))]))

  (define (make-dispatcher start-inside? ch:command
                           get-command-readtable get-datum-readtable
                           syntax-post-processor)
    (define re:command (^px ch:command
                            ;; the following identifies string and expression
                            ;; escapes, see how it is used above
                            "(?:(\")|("ch:expr-escape"))?"))
    (define (re:line-item* bgn end cmd-prefix)
      (^px "(.+?)(?:" (and bgn `(,bgn"|")) (and end `(,end"|"))
           cmd-prefix ch:command"|"str:end-of-line"|$)"))
    (define re:line-item (re:line-item* ch:lines-begin ch:lines-end #f))
    (define re:line-item-no-nests (and start-inside? (re:line-item* #f #f #f)))
    (lambda (char inp source-name line-num col-num position)
      (dispatcher char inp source-name line-num col-num position
                  start-inside? (get-command-readtable) ch:command
                  re:command re:line-item* re:line-item re:line-item-no-nests
                  (get-datum-readtable) syntax-post-processor)))

  ;; ----------------------------------------------------------------------------
  ;; minor utilities for the below

  (define default-src (gensym 'scribble-reader))
  (define (src-name src port)
    (if (eq? src default-src) (object-name port) src))

  (define-syntax-rule (named-lambda (name . args) . body)
    (let ([name (lambda args . body)]) name))

  ;; ----------------------------------------------------------------------------
  ;; readtable and reader

  (provide make-at-readtable make-at-reader)

  (define ((make-at-readtable-or-inside-reader inside-reader?)
           readtable command-char command-readtable datum-readtable syntax-post-processor)
    (define (get-cmd-rt)
      (if (readtable? cmd-rt)
          cmd-rt
          (cmd-rt)))
    (define (get-datum-rt)
      (if (eq? datum-rt 'dynamic)
          (current-readtable)
          datum-rt))
    (define dispatcher
      (make-dispatcher #f command-char get-cmd-rt get-datum-rt
                       syntax-post-processor))
    (define (make-inside-reader)
      (define dispatcher
        (make-dispatcher #t command-char get-cmd-rt get-datum-rt
                         syntax-post-processor))
      ;; use a name consistent with `make-at-reader'
      (named-lambda (at-read-syntax/inside [src default-src]
                                           [inp (current-input-port)])
                    (define-values [line col pos] (port-next-location inp))
                    (parameterize ([current-readtable at-rt])
                      (dispatcher #f inp (src-name src inp) line col pos))))
    (define at-rt
      (make-readtable readtable command-char 'non-terminating-macro dispatcher))
    (define command-bar
      (lambda (char inp source-name line-num col-num position)
        (let ([m (*regexp-match #rx#"^([^|]*)\\|" inp)])
          (unless m
            (raise-read-error "unbalanced `|'" source-name
                              line-num col-num position #f))
          (datum->syntax
           #f (string->symbol (bytes->string/utf-8 (cadr m)))
           (vector source-name line-num col-num position
                   (add1 (bytes-length (car m))))
           orig-stx))))
    (define (make-cmd-rt command-readtable)
      ;; similar to plain Racket (scribble, actually), but with `@' as usual and
      ;; and `|' as a terminating macro characters (otherwise it behaves the
      ;; same; the only difference is that `a|b|c' is three symbols)
      (make-readtable command-readtable
                      command-char 'non-terminating-macro dispatcher
                      #\| 'terminating-macro command-bar))
    (define cmd-rt
      (if (eq? command-readtable 'dynamic)
          (readtable-cached make-cmd-rt)
          (make-cmd-rt command-readtable)))
    (define datum-rt
      (cond [(or (not datum-readtable) (readtable? datum-readtable))
             datum-readtable]
            [(eq? #t datum-readtable) at-rt]
            [(procedure? datum-readtable) (datum-readtable at-rt)]
            [(eq? datum-readtable 'dynamic) 'dynamic]
            [else (error 'make-at-readtable
                         "bad datum-readtable: ~e" datum-readtable)]))
    (if inside-reader? (make-inside-reader) at-rt))

  (define (make-at-readtable
           #:readtable             [readtable (current-readtable)]
           #:command-char          [command-char ch:command]
           #:command-readtable     [command-readtable readtable]
           #:datum-readtable       [datum-readtable #t]
           #:syntax-post-processor [syntax-post-processor values])
    ((make-at-readtable-or-inside-reader #f)
     readtable command-char command-readtable datum-readtable syntax-post-processor))

  (define (make-at-reader
           #:readtable             [readtable (current-readtable)]
           #:command-char          [command-char ch:command]
           #:datum-readtable       [datum-readtable #t]
           #:command-readtable     [command-readtable readtable]
           #:syntax-post-processor [syntax-post-processor values]
           #:syntax?               [syntax-reader? #t]
           #:inside?               [inside-reader? #f])
    (let ([r ((make-at-readtable-or-inside-reader inside-reader?)
              readtable command-char command-readtable datum-readtable syntax-post-processor)])
      ;; the result can be a readtable or a syntax reader, depending on inside?,
      ;; convert it now to the appropriate reader
      (if inside-reader?
          ;; if it's a function, then it already is a syntax reader, convert it to
          ;; a plain reader if needed (note: this only happens when r is a reader)
          (if syntax-reader?
              r
              (named-lambda (at-read/inside [in (current-input-port)])
                            ;; can't be eof, since it returns a list of expressions (as a syntax)
                            (syntax->datum (r (object-name in) in))))
          ;; if it's a readtable, then just wrap the standard functions
          (if syntax-reader?
              (named-lambda (at-read-syntax [src default-src]
                                            [inp (current-input-port)])
                            (parameterize ([current-readtable r])
                              (read-syntax src inp)))
              (named-lambda (at-read [inp (current-input-port)])
                            (parameterize ([current-readtable r])
                              (let ([r (read-syntax (object-name inp) inp)])
                                ;; it might be eof
                                (if (syntax? r) (syntax->datum r) r))))))))

  (provide use-at-readtable)
  (define use-at-readtable
    (make-keyword-procedure
     (lambda (kws kw-args . rest)
       (port-count-lines! (current-input-port))
       (current-readtable
        (keyword-apply make-at-readtable kws kw-args rest)))))

  ;; utilities for below
  (define make-default-at-readtable
    (readtable-cached (lambda (rt) (make-at-readtable #:readtable rt
                                                      #:command-readtable 'dynamic
                                                      #:datum-readtable 'dynamic))))
  (define make-default-at-reader/inside
    (readtable-cached
     (lambda (rt) (make-at-reader #:inside? #t #:readtable rt
                                  #:command-readtable 'dynamic
                                  #:datum-readtable 'dynamic))))

  ;; ----------------------------------------------------------------------------
  ;; readers

  (provide (rename-out [*read read] [*read-syntax read-syntax]))
  (define (*read [inp (current-input-port)])
    (parameterize ([current-readtable (make-default-at-readtable)])
      (read inp)))
  (define (*read-syntax [src default-src] [inp (current-input-port)])
    (parameterize ([current-readtable (make-default-at-readtable)])
      (read-syntax (src-name src inp) inp)))

  (provide read-inside read-syntax-inside)
  (define (read-inside [inp (current-input-port)])
    (syntax->datum ((make-default-at-reader/inside) default-src inp)))
  (define (read-syntax-inside [src default-src] [inp (current-input-port)] 
                              #:command-char [command-char ch:command])
    (((readtable-cached
       (lambda (rt) (make-at-reader #:inside? #t #:command-char command-char #:readtable rt))))
     src inp)))