From d9c064d06c1fd48974a3d6fd9763d2a235abc32c Mon Sep 17 00:00:00 2001 From: lkh01 Date: Sat, 21 Mar 2020 18:34:27 +0100 Subject: [PATCH] make `syntax->string` work with unquote, quasiquote, etc. --- pkgs/racket-test/tests/syntax/to-string.rkt | 98 +++++++++++++++++++++ racket/collects/syntax/to-string.rkt | 20 ++++- 2 files changed, 114 insertions(+), 4 deletions(-) diff --git a/pkgs/racket-test/tests/syntax/to-string.rkt b/pkgs/racket-test/tests/syntax/to-string.rkt index 61bb57c0e2..57b6e7a330 100644 --- a/pkgs/racket-test/tests/syntax/to-string.rkt +++ b/pkgs/racket-test/tests/syntax/to-string.rkt @@ -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 )") + + diff --git a/racket/collects/syntax/to-string.rkt b/racket/collects/syntax/to-string.rkt index 8aa4b96203..530a6334ed 100644 --- a/racket/collects/syntax/to-string.rkt +++ b/racket/collects/syntax/to-string.rkt @@ -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))