155 lines
4.9 KiB
Scheme
155 lines
4.9 KiB
Scheme
#lang scheme/base
|
|
(require (for-syntax scheme/base "rep.ss")
|
|
scheme/match)
|
|
(provide (for-syntax expectation-of-stxclass
|
|
expectation-of-constants)
|
|
try
|
|
empty-expectation?
|
|
expectation->string)
|
|
|
|
(define-struct scdyn (name desc)
|
|
#:transparent)
|
|
|
|
(define-struct expc (stxclasses pairs? data literals)
|
|
#:transparent)
|
|
|
|
(begin-for-syntax
|
|
(define certify (syntax-local-certifier))
|
|
(define (expectation-of-stxclass stxclass)
|
|
(if stxclass
|
|
(with-syntax ([name (sc-name stxclass)]
|
|
[desc (sc-description stxclass)])
|
|
(certify #'(make-expc (list (make-scdyn 'name 'desc)) #f null null)))
|
|
#'#f))
|
|
|
|
(define (expectation-of-constants pairs? data literals)
|
|
(with-syntax ([(datum ...) data]
|
|
[(literal ...) literals]
|
|
[pairs? pairs?])
|
|
(certify
|
|
#'(make-expc null 'pairs? (list 'datum ...) (list (quote-syntax literal) ...))))))
|
|
|
|
|
|
(define-syntax try
|
|
(syntax-rules ()
|
|
[(try failvar (expr0))
|
|
expr0]
|
|
[(try failvar (expr0 . exprs))
|
|
(let ([failvar
|
|
(lambda (x1 p1 r1 f1)
|
|
(let ([failvar
|
|
(lambda (x2 p2 r2 f2)
|
|
(choose-error failvar x1 x2 p1 p2 r1 r2 f1 f2))])
|
|
(try failvar exprs)))])
|
|
expr0)]))
|
|
|
|
(define (choose-error k x1 x2 p1 p2 r1 r2 frontier1 frontier2)
|
|
(define (go1) (k x1 p1 r1 frontier1))
|
|
(define (go2) (k x2 p2 r2 frontier2))
|
|
(let loop ([f1 frontier1] [f2 frontier2])
|
|
(cond [(and (null? f1) (null? f2))
|
|
(let ([p (merge-expectations p1 p2)])
|
|
(k x1 p #f frontier1))]
|
|
[(and (pair? f1) (null? f2)) (go1)]
|
|
[(and (null? f1) (pair? f2)) (go2)]
|
|
[(and (pair? f1) (pair? f2))
|
|
(let ([c1 (cadr f1)]
|
|
[c2 (cadr f2)])
|
|
(cond [(> c1 c2) (go1)]
|
|
[(< c1 c2) (go2)]
|
|
[else (loop (cddr f1) (cddr f2))]))])))
|
|
|
|
(define (merge-expectations e1 e2)
|
|
(make-expc (union (expc-stxclasses e1) (expc-stxclasses e2))
|
|
(or (expc-pairs? e1) (expc-pairs? e2))
|
|
(union (expc-data e1) (expc-data e2))
|
|
(union (expc-literals e1) (expc-literals e2))))
|
|
|
|
(define union append)
|
|
|
|
(define (empty-expectation? e)
|
|
(match e
|
|
[(struct expc (scs pairs? data literals))
|
|
(and (null? scs)
|
|
(not pairs?)
|
|
(null? literals)
|
|
(and (pair? data) (null? (cdr data)))
|
|
(equal? (car data) '()))]))
|
|
|
|
(define (expectation->string e)
|
|
(match e
|
|
[(struct expc (_ #t _ _))
|
|
#f]
|
|
[(struct expc (stxclasses pairs? data literals))
|
|
(let ([s1 (and (pair? stxclasses) (string-of-stxclasses stxclasses))]
|
|
[s2 (and (pair? data) (string-of-data data))]
|
|
[s3 (and (pair? literals) (string-of-literals literals))]
|
|
[s4 (and pairs? string-of-pairs?)])
|
|
(join-sep (filter string? (list s1 s2 s3 s4))
|
|
";"
|
|
"or"))]))
|
|
|
|
(define (string-of-stxclasses stxclasses)
|
|
(comma-list (map string-of-stxclass stxclasses)))
|
|
|
|
(define (string-of-stxclass stxclass)
|
|
(and stxclass
|
|
(format "~a"
|
|
(or (scdyn-desc stxclass)
|
|
(scdyn-name stxclass)))))
|
|
|
|
(define (string-of-literals literals0)
|
|
(define literals
|
|
(sort (map syntax-e literals0)
|
|
string<?
|
|
#:key symbol->string
|
|
#:cache-keys? #t))
|
|
(case (length literals)
|
|
[(1) (format "the literal identifier ~s" (car literals))]
|
|
[else (format "one of the following literal identifiers: ~a"
|
|
(comma-list (map ->string literals)))]))
|
|
|
|
(define (string-of-data data)
|
|
(case (length data)
|
|
[(1) (format "the literal ~s" (car data))]
|
|
[else (format "one of the following literals: ~a"
|
|
(comma-list (map ->string data)))]))
|
|
|
|
(define (->string x) (format "~s" x))
|
|
|
|
(define string-of-pairs?
|
|
"structured syntax")
|
|
|
|
(define (comma-list items)
|
|
(join-sep items "," "or"))
|
|
|
|
(define (join-sep items sep0 ult0)
|
|
(define sep (string-append sep0 " "))
|
|
(define ult (string-append ult0 " "))
|
|
(define (loop items)
|
|
(cond [(null? items)
|
|
null]
|
|
[(null? (cdr items))
|
|
(list sep ult (car items))]
|
|
[else
|
|
(list* sep (car items) (loop (cdr items)))]))
|
|
(case (length items)
|
|
[(2) (format "~a ~a~a" (car items) ult (cadr items))]
|
|
[else (let ([strings (list* (car items) (loop (cdr items)))])
|
|
(apply string-append strings))]))
|
|
|
|
;; (define (comma-list items0)
|
|
;; (define items (for/list ([item items0]) (format "~s" item)))
|
|
;; (define (loop items)
|
|
;; (cond [(null? items)
|
|
;; null]
|
|
;; [(null? (cdr items))
|
|
;; (list ", or " (car items))]
|
|
;; [else
|
|
;; (list* ", " (car items) (loop (cdr items)))]))
|
|
;; (case (length items)
|
|
;; [(2) (format "~a or ~a" (car items) (cadr items))]
|
|
;; [else (let ([strings (list* (car items) (loop (cdr items)))])
|
|
;; (apply string-append strings))]))
|
|
|