make txexpr a match-expander #8

Merged
AlexKnauth merged 6 commits from match-expander into master 6 years ago

@ -9,7 +9,7 @@ env:
global:
- RACKET_DIR=~/racket
matrix:
- RACKET_VERSION=6.0
- RACKET_VERSION=6.0.1
# - RACKET_VERSION=6.1
# - RACKET_VERSION=6.2
- RACKET_VERSION=6.3

@ -1,5 +1,9 @@
#lang racket/base
(require racket/match sugar/define sugar/list sugar/coerce racket/string racket/list xml)
(require racket/match sugar/define sugar/list sugar/coerce
racket/string racket/list
xml
"private/define-provide-safe-match.rkt"
(for-syntax racket/base syntax/parse))
(provide cdata? cdata valid-char? xexpr->string xexpr?) ; from xml
(provide empty) ; from racket/list
@ -124,9 +128,15 @@
(raise-argument-error func-name "txexpr-elements?" elements))
(txexpr-unsafe tag attrs elements))
(define+provide+safe (txexpr tag [attrs null] [elements null])
(define+provide+safe+match (txexpr tag [attrs null] [elements null])
((txexpr-tag?) (txexpr-attrs? txexpr-elements?) . ->* . txexpr?)
(txexpr-base 'txexpr tag attrs elements))
(txexpr-base 'txexpr tag attrs elements)
#:match-expander
(syntax-parser
[(_ tag-pat:expr
{~optional attrs-pat:expr #:defaults ([attrs-pat #'_])}
{~optional elements-pat:expr #:defaults ([elements-pat #'_])})
#'(? txexpr? (app txexpr->values tag-pat attrs-pat elements-pat))]))
(define+provide+safe (txexpr* tag [attrs null] . elements)
((txexpr-tag?) (txexpr-attrs?) #:rest txexpr-elements? . ->* . txexpr?)

@ -0,0 +1,82 @@
#lang racket/base
(provide define+provide+safe+match)
(require racket/match
(for-syntax racket/base
racket/syntax
syntax/parse
syntax/stx
version/utils))
;; (define+provide+safe+match name-id
;; contract-expr
;; value-expr
;; #:match-expander
;; match-transformer-expr)
;;
;; (define+provide+safe+match (head . args)
;; contract-expr
;; value-body-expr
;; ...+
;; #:match-expander
;; match-transformer-expr)
(begin-for-syntax
;; Identifier -> [Syntax -> Syntax]
(define ((variable-like-transformer id) stx)
(cond
[(identifier? stx)
; id, but with the source location of stx
(datum->syntax id (syntax-e id) stx id)]
[(stx-pair? stx)
(datum->syntax stx (cons id (stx-cdr stx)) stx stx)])))
(define-syntax define+provide+safe+match
(λ (stx)
(syntax-parse stx
[(d (head . args)
contract:expr
value-body:expr ...+
#:match-expander match-transformer:expr)
#:with fn-expr (syntax/loc stx (λ args value-body ...))
(syntax/loc stx
(d head contract fn-expr #:match-expander match-transformer))]
[(_ name:id
contract:expr
value:expr
#:match-expander match-transformer:expr)
#:with internal-name (generate-temporary #'name)
#:with contract-name (generate-temporary #'name)
#:with make-name-match-transformer (generate-temporary #'name)
#:with [name-for-blame ...]
(cond [(version<=? "6.8" (version)) #'[#:name-for-blame name]]
[else #'[]])
#'(begin
(define internal-name (let ([name value]) name))
(begin-for-syntax
(define (make-name-match-transformer name)
(with-syntax ([name name]) match-transformer)))
(define-match-expander name
(make-name-match-transformer (quote-syntax internal-name))
(variable-like-transformer (quote-syntax internal-name)))
(provide name)
(module+ safe
(require racket/contract/base)
(define-module-boundary-contract contract-name internal-name contract
name-for-blame ...)
(define-match-expander name
(make-name-match-transformer (quote-syntax contract-name))
(variable-like-transformer (quote-syntax contract-name)))
(provide name)))])))

@ -0,0 +1,16 @@
#lang racket/base
(require (submod "../main.rkt" safe))
(module+ test
(require rackunit))
(module+ test
(check-exn (regexp (string-append
"txexpr.*: contract violation\n"
" *expected: txexpr-tag\\?\n"
" *given: 4\n"
" *in: the 1st argument.*"
" *blaming: .*test/contract-tests.rkt"))
(λ () (txexpr 4)))
)

@ -109,6 +109,19 @@
(check-equal? (values->list (txexpr->values '(p ((key "value")) "foo")))
(txexpr->list '(p ((key "value")) "foo")))
;; testing the match expander success
(check-match '(p ((key "value")) "leaf")
(txexpr 'p `((key ,val)) (list "leaf"))
(string=? val "value"))
;; testing the match expander failure
(check-false (match '(p ((key "value")) "something")
[(txexpr 'p _ (list "else")) #true]
[_ #false]))
(check-false (match "foo"
[(txexpr _ _ _) #true]
[_ #false]))
(check-equal? (get-tag '(p ((key "value"))"foo" "bar" (em "square"))) 'p)
(check-equal? (get-attrs '(p ((key "value"))"foo" "bar" (em "square"))) '((key "value")))
(check-equal? (get-elements '(p ((key "value"))"foo" "bar" (em "square")))

Loading…
Cancel
Save