230 lines
8.1 KiB
Racket
230 lines
8.1 KiB
Racket
#lang racket/base
|
|
|
|
(provide read-pexpr
|
|
string->pexpr
|
|
|
|
pexpr->preserve
|
|
preserve->pexpr
|
|
|
|
COMMA
|
|
SEMICOLON
|
|
TRAILER-ANCHOR
|
|
COLONS
|
|
|
|
*COMMA*
|
|
*SEMICOLON*
|
|
*TRAILER-ANCHOR*
|
|
|
|
RECORD
|
|
BLOCK
|
|
GROUP
|
|
SET
|
|
|
|
remove-trailer)
|
|
|
|
(require (for-syntax racket/base))
|
|
(require racket/match)
|
|
(require racket/set)
|
|
(require "record.rkt")
|
|
(require "annotation.rkt")
|
|
(require "embedded.rkt")
|
|
(require "read-text-generic.rkt")
|
|
(require (only-in racket/list append-map))
|
|
|
|
(define *reader-name* 'read-pexpr)
|
|
|
|
(define *COMMA* (record 'p '(|,|)))
|
|
(define *SEMICOLON* (record 'p '(|;|)))
|
|
(define *TRAILER-ANCHOR* (record 'a '()))
|
|
|
|
(define-match-expander COMMA
|
|
(syntax-rules () [(_) (strip-annotations (== *COMMA*) #:depth 3)])
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_) #'*COMMA*]
|
|
[_ #'(lambda () *COMMA*)])))
|
|
|
|
(define-match-expander SEMICOLON
|
|
(syntax-rules () [(_) (strip-annotations (== *SEMICOLON*) #:depth 3)])
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_) #'*SEMICOLON*]
|
|
[_ #'(lambda () *SEMICOLON*)])))
|
|
|
|
(define-match-expander TRAILER-ANCHOR
|
|
(syntax-rules () [(_) (strip-annotations (== *TRAILER-ANCHOR*) #:depth 2)])
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_) #'*TRAILER-ANCHOR*]
|
|
[_ #'(lambda () *TRAILER-ANCHOR*)])))
|
|
|
|
(define-match-expander RECORD
|
|
(syntax-rules () [(_ ps ...) (strip-annotations (record 'r (list ps ...)) #:depth 2)])
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ v ...) #'(record 'r (list v ...))]
|
|
[_ #'(lambda vs (record 'r vs))])))
|
|
|
|
(define-match-expander BLOCK
|
|
(syntax-rules () [(_ ps ...) (strip-annotations (record 'b (list ps ...)) #:depth 2)])
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ v ...) #'(record 'b (list v ...))]
|
|
[_ #'(lambda vs (record 'b vs))])))
|
|
|
|
(define-match-expander GROUP
|
|
(syntax-rules () [(_ ps ...) (strip-annotations (record 'g (list ps ...)) #:depth 2)])
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ v ...) #'(record 'g (list v ...))]
|
|
[_ #'(lambda vs (record 'g vs))])))
|
|
|
|
(define-match-expander SET
|
|
(syntax-rules () [(_ ps ...) (strip-annotations (record 's (list ps ...)) #:depth 2)])
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ v ...) #'(record 's (list v ...))]
|
|
[_ #'(lambda vs (record 's vs))])))
|
|
|
|
(define (colon-sym-length s)
|
|
(and (symbol? s)
|
|
(let ((s (string->list (symbol->string s))))
|
|
(and (andmap (lambda (c) (eqv? c #\:)) s)
|
|
(length s)))))
|
|
|
|
(define (colon-sym n) (string->symbol (make-string n #\:)))
|
|
(define (make-colons n) (record 'p (list (colon-sym n))))
|
|
|
|
(define-match-expander COLONS
|
|
(syntax-rules () [(_ n) (strip-annotations (record 'p (list (app colon-sym-length n))) #:depth 3)])
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ n) (let ((s (string->symbol (make-string (syntax->datum #'n) #\:)))) #`(record 'p '(#,s)))]
|
|
[_ #'make-colons])))
|
|
|
|
(define (remove-trailer ps)
|
|
(filter (match-lambda [(TRAILER-ANCHOR) #f] [_ #t]) ps))
|
|
|
|
(define pexpr-reader
|
|
(make-preserve-text-reader
|
|
#:reader-name *reader-name*
|
|
#:read-annotated-value (lambda (in-port source next parse-error*)
|
|
(lambda ()
|
|
(skip-whitespace in-port)
|
|
(match (peek-char in-port)
|
|
[(or (? eof-object?) #\] #\> #\} #\)) *TRAILER-ANCHOR*]
|
|
[_ (next)])))
|
|
#:on-hash (lambda (in-port source next parse-error* default)
|
|
(match-lambda
|
|
[#\{ (read-sequence 's in-port source next #\})]
|
|
[c (default c)]))
|
|
#:on-char (lambda (in-port source next parse-error* default)
|
|
(match-lambda
|
|
[#\< (read-sequence 'r in-port source next #\>)]
|
|
[#\[ (read-sequence #f in-port source next #\])]
|
|
[#\{ (read-sequence 'b in-port source next #\})]
|
|
[#\( (read-sequence 'g in-port source next #\))]
|
|
[#\, *COMMA*]
|
|
[#\; *SEMICOLON*]
|
|
[#\: (let loop ((acc '(#\:)))
|
|
(match (peek-char in-port)
|
|
[#\: (loop (cons (read-char in-port) acc))]
|
|
[_ (record 'p (list (string->symbol (list->string (reverse acc)))))]))]
|
|
[c (default c)]))))
|
|
|
|
(define string->pexpr (make-preserve-string-reader *reader-name* pexpr-reader))
|
|
|
|
(define (read-sequence record-label in-port source next terminator-char)
|
|
(let loop ((acc '()))
|
|
(skip-whitespace in-port)
|
|
(match (eof-guard *reader-name* in-port source (peek-char in-port))
|
|
[(== terminator-char)
|
|
(read-char in-port)
|
|
(if record-label
|
|
(record record-label (reverse acc))
|
|
(reverse acc))]
|
|
[_
|
|
(match (next)
|
|
[(record 'a '()) ;; skip bare annotation-anchors
|
|
;; NB. Not matching (TRAILER-ANCHOR)! That would skip *non-bare* anchors too!
|
|
(loop acc)]
|
|
[v (loop (cons v acc))])])))
|
|
|
|
(define (read-pexpr [in-port (current-input-port)]
|
|
#:read-syntax? [read-syntax? #f]
|
|
#:decode-embedded [decode-embedded #f]
|
|
#:source [source (object-name in-port)])
|
|
(pexpr-reader in-port source read-syntax? decode-embedded))
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
(define (uncomma p
|
|
#:map-embedded [map-embedded (lambda (walk v) (walk v))])
|
|
(define (walk-seq ps)
|
|
(map walk (filter (match-lambda [(COMMA) #f] [_ #t]) ps)))
|
|
|
|
(define (walk p)
|
|
(match p
|
|
[(? list? ps) (walk-seq ps)]
|
|
[(RECORD ps ...) (apply RECORD (walk-seq ps))]
|
|
[(GROUP ps ...) (apply GROUP (walk-seq ps))]
|
|
[(BLOCK ps ...) (apply BLOCK (walk-seq ps))]
|
|
[(SET ps ...) (apply SET (walk-seq ps))]
|
|
[(embedded v) (map-embedded walk v)]
|
|
[(annotated as loc v) (annotated (map walk as) loc (walk v))]
|
|
[(COMMA) (error 'uncomma "Cannot remove commas from term with comma outside container")]
|
|
[v v]))
|
|
|
|
(walk p))
|
|
|
|
(define (pexpr->preserve p
|
|
#:discard-trailers? [discard-trailers? #f]
|
|
#:map-embedded [map-embedded (lambda (walk v) (walk v))])
|
|
(define untrailer (if discard-trailers? remove-trailer values))
|
|
(let walk ((p (uncomma p #:map-embedded map-embedded)))
|
|
(match p
|
|
[(list ps ...)
|
|
(map walk (untrailer ps))]
|
|
[(RECORD l ps ...) (record (walk l) (map walk (untrailer ps)))]
|
|
[(GROUP _ ...) (error 'pexpr->preserve "Cannot convert uninterpreted grouping")]
|
|
[(BLOCK ps ...)
|
|
(let loop ((acc (hash)) (ps (untrailer ps)))
|
|
(match ps
|
|
[(list)
|
|
acc]
|
|
[(list k0 (COLONS 1) v more ...)
|
|
(define k (walk k0))
|
|
(if (hash-has-key? acc k)
|
|
(error 'pexpr->preserve "Duplicate key in dictionary: ~v" k)
|
|
(loop (hash-set acc k (walk v)) more))]
|
|
[_
|
|
(error 'pexpr->preserve "Cannot convert invalid dictionary")]))]
|
|
[(SET ps ...)
|
|
(let loop ((acc (set)) (ps (untrailer ps)))
|
|
(match ps
|
|
['() acc]
|
|
[(cons v0 more)
|
|
(define v (walk v0))
|
|
(if (set-member? acc v)
|
|
(error 'pexpr->preserve "Duplicate item in set: ~v" v)
|
|
(loop (set-add acc v) more))]))]
|
|
[(SEMICOLON) (error 'pexpr->preserve "Cannot convert semicolon")]
|
|
[(COLONS _) (error 'pexpr->preserve "Cannot convert colons")]
|
|
[(TRAILER-ANCHOR) (error 'pexpr->preserve "Cannot convert trailer")]
|
|
[(embedded v) (map-embedded walk v)]
|
|
[(annotated as loc v) (annotated (map walk as) loc (walk v))]
|
|
[v v])))
|
|
|
|
(define (preserve->pexpr v #:map-embedded [map-embedded (lambda (walk v) (walk v))])
|
|
(let walk ((v v))
|
|
(match v
|
|
[(list vs ...) (map walk vs)]
|
|
[(? set?) (record 's (map walk (set->list v)))]
|
|
[(hash-table (kk vv) ...)
|
|
(record 'b (append-map (lambda (kk vv) (list (walk kk) (COLONS 1) (walk vv)))
|
|
kk vv))]
|
|
[(record l fs) (record 'r (map walk (cons l fs)))]
|
|
[(embedded v) (map-embedded walk v)]
|
|
[(annotated as loc v) (annotated (map walk as) loc (walk v))]
|
|
[v v])))
|