suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

make syntax->string work with unquote, quasiquote, etc.

Browse Source
This commit is contained in:
lkh01 2020-03-21 18:34:27 +01:00 committed by Sam Tobin-Hochstadt
parent 6a7ad2e49e
commit d9c064d06c
2 changed files with 114 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
pkgs/racket-test/tests/syntax/to-string.rkt
View File

@ -23,3 +23,101 @@
(check-equal? (syntax->string #'(( quote . a ))) "( quote . a )")
(check-equal? (syntax->string #'((quote a b . c))) "(quote a b . c)")
(check-equal? (syntax->string #'(( quote a b . c ))) "( quote a b . c )")
;; unquote tests
(check-equal? (syntax->string #'(,a)) ",a")
(check-equal? (syntax->string #'(, a)) ", a")
(check-equal? (syntax->string #'((unquote a))) "(unquote a)")
(check-equal? (syntax->string #'(( unquote a ))) "( unquote a )")
(check-equal? (syntax->string #'((unquote a b))) "(unquote a b)")
(check-equal? (syntax->string #'(( unquote a b ))) "( unquote a b )")
(check-equal? (syntax->string #'((unquote . a))) "(unquote . a)")
(check-equal? (syntax->string #'(( unquote . a ))) "( unquote . a )")
(check-equal? (syntax->string #'((unquote a b . c))) "(unquote a b . c)")
(check-equal? (syntax->string #'(( unquote a b . c ))) "( unquote a b . c )")
;; quasiquote tests
(check-equal? (syntax->string #'(`a)) "`a")
(check-equal? (syntax->string #'(` a)) "` a")
(check-equal? (syntax->string #'((quasiquote a))) "(quasiquote a)")
(check-equal? (syntax->string #'(( quasiquote a ))) "( quasiquote a )")
(check-equal? (syntax->string #'((quasiquote a b))) "(quasiquote a b)")
(check-equal? (syntax->string #'(( quasiquote a b ))) "( quasiquote a b )")
(check-equal? (syntax->string #'((quasiquote . a))) "(quasiquote . a)")
(check-equal? (syntax->string #'(( quasiquote . a ))) "( quasiquote . a )")
(check-equal? (syntax->string #'((quasiquote a b . c))) "(quasiquote a b . c)")
(check-equal? (syntax->string #'(( quasiquote a b . c ))) "( quasiquote a b . c )")
;; unquote-splicing tests
(check-equal? (syntax->string #'(,@a)) ",@a")
(check-equal? (syntax->string #'(,@ a)) ",@ a")
(check-equal? (syntax->string #'((unquote-splicing a))) "(unquote-splicing a)")
(check-equal? (syntax->string #'(( unquote-splicing a ))) "( unquote-splicing a )")
(check-equal? (syntax->string #'((unquote-splicing a b))) "(unquote-splicing a b)")
(check-equal? (syntax->string #'(( unquote-splicing a b ))) "( unquote-splicing a b )")
(check-equal? (syntax->string #'((unquote-splicing . a))) "(unquote-splicing . a)")
(check-equal? (syntax->string #'(( unquote-splicing . a ))) "( unquote-splicing . a )")
(check-equal? (syntax->string #'((unquote-splicing a b . c))) "(unquote-splicing a b . c)")
(check-equal? (syntax->string #'(( unquote-splicing a b . c ))) "( unquote-splicing a b . c )")
;; syntax tests
(check-equal? (syntax->string #'(#'a)) "#'a")
(check-equal? (syntax->string #'(#' a)) "#' a")
(check-equal? (syntax->string #'((syntax a))) "(syntax a)")
(check-equal? (syntax->string #'(( syntax a ))) "( syntax a )")
(check-equal? (syntax->string #'((syntax a b))) "(syntax a b)")
(check-equal? (syntax->string #'(( syntax a b ))) "( syntax a b )")
(check-equal? (syntax->string #'((syntax . a))) "(syntax . a)")
(check-equal? (syntax->string #'(( syntax . a ))) "( syntax . a )")
(check-equal? (syntax->string #'((syntax a b . c))) "(syntax a b . c)")
(check-equal? (syntax->string #'(( syntax a b . c ))) "( syntax a b . c )")
;; quasisyntax tests
(check-equal? (syntax->string #'(#`a)) "#`a")
(check-equal? (syntax->string #'(#` a)) "#` a")
(check-equal? (syntax->string #'((quasisyntax a))) "(quasisyntax a)")
(check-equal? (syntax->string #'(( quasisyntax a ))) "( quasisyntax a )")
(check-equal? (syntax->string #'((quasisyntax a b))) "(quasisyntax a b)")
(check-equal? (syntax->string #'(( quasisyntax a b ))) "( quasisyntax a b )")
(check-equal? (syntax->string #'((quasisyntax . a))) "(quasisyntax . a)")
(check-equal? (syntax->string #'(( quasisyntax . a ))) "( quasisyntax . a )")
(check-equal? (syntax->string #'((quasisyntax a b . c))) "(quasisyntax a b . c)")
(check-equal? (syntax->string #'(( quasisyntax a b . c ))) "( quasisyntax a b . c )")
;; unsyntax tests
(check-equal? (syntax->string #'(#,a)) "#,a")
(check-equal? (syntax->string #'(#, a)) "#, a")
(check-equal? (syntax->string #'((unsyntax a))) "(unsyntax a)")
(check-equal? (syntax->string #'(( unsyntax a ))) "( unsyntax a )")
(check-equal? (syntax->string #'((unsyntax a b))) "(unsyntax a b)")
(check-equal? (syntax->string #'(( unsyntax a b ))) "( unsyntax a b )")
(check-equal? (syntax->string #'((unsyntax . a))) "(unsyntax . a)")
(check-equal? (syntax->string #'(( unsyntax . a ))) "( unsyntax . a )")
(check-equal? (syntax->string #'((unsyntax a b . c))) "(unsyntax a b . c)")
(check-equal? (syntax->string #'(( unsyntax a b . c ))) "( unsyntax a b . c )")
;; unsyntax tests
(check-equal? (syntax->string #'(#,a)) "#,a")
(check-equal? (syntax->string #'(#, a)) "#, a")
(check-equal? (syntax->string #'((unsyntax a))) "(unsyntax a)")
(check-equal? (syntax->string #'(( unsyntax a ))) "( unsyntax a )")
(check-equal? (syntax->string #'((unsyntax a b))) "(unsyntax a b)")
(check-equal? (syntax->string #'(( unsyntax a b ))) "( unsyntax a b )")
(check-equal? (syntax->string #'((unsyntax . a))) "(unsyntax . a)")
(check-equal? (syntax->string #'(( unsyntax . a ))) "( unsyntax . a )")
(check-equal? (syntax->string #'((unsyntax a b . c))) "(unsyntax a b . c)")
(check-equal? (syntax->string #'(( unsyntax a b . c ))) "( unsyntax a b . c )")
;; unsyntax-splicing tests
(check-equal? (syntax->string #'(#,@a)) "#,@a")
(check-equal? (syntax->string #'(#,@ a)) "#,@ a")
(check-equal? (syntax->string #'((unsyntax-splicing a))) "(unsyntax-splicing a)")
(check-equal? (syntax->string #'(( unsyntax-splicing a ))) "( unsyntax-splicing a )")
(check-equal? (syntax->string #'((unsyntax-splicing a b))) "(unsyntax-splicing a b)")
(check-equal? (syntax->string #'(( unsyntax-splicing a b ))) "( unsyntax-splicing a b )")
(check-equal? (syntax->string #'((unsyntax-splicing . a))) "(unsyntax-splicing . a)")
(check-equal? (syntax->string #'(( unsyntax-splicing . a ))) "( unsyntax-splicing . a )")
(check-equal? (syntax->string #'((unsyntax-splicing a b . c))) "(unsyntax-splicing a b . c)")
(check-equal? (syntax->string #'(( unsyntax-splicing a b . c ))) "( unsyntax-splicing a b . c )")

20
racket/collects/syntax/to-string.rkt
View File

@ -20,6 +20,17 @@
(when c
(display (make-string (max 0 (- c col)) #\space))
(set! col c))))
(define quotes-table
#hasheq((quote . "'")
(quasiquote . "`")
(unquote . ",")
(unquote-splicing . ",@")
(syntax . "#'")
(quasisyntax . "#`")
(unsyntax . "#,")
(unsyntax-splicing . "#,@")))
(define (get-quote c)
(hash-ref quotes-table (syntax-e (car (syntax-e c)))))
(parameterize ([current-output-port s]
[read-case-sensitive #t])
(define (loop init-line!)
@ -50,11 +61,12 @@
(printf "; ")))
l))]
[(and (pair? (syntax-e c))
(eq? (syntax-e (car (syntax-e c))) 'quote)
(eq? (syntax-span (car (syntax-e c))) 1))
(hash-has-key? quotes-table (syntax-e (car (syntax-e c))))
(eq? (syntax-span (car (syntax-e c)))
(string-length (get-quote c))))
(advance c init-line!)
(printf "'")
(set! col (+ col 1))
(printf (get-quote c))
(set! col (+ col (string-length (get-quote c))))
(let ([i (cadr (syntax->list c))])
((loop init-line!) i))]
[(pair? (syntax-e c))