From 7597d05b62420effd2b258114f637890810060aa Mon Sep 17 00:00:00 2001 From: Jack Firth Date: Tue, 13 Aug 2024 00:59:20 -0700 Subject: [PATCH] Simplify define-pretty macro This commit changes the `pretty` syntax parameter to an ordinary function that calls whatever function is in `current-pretty`. This removes the need for the `#:default` keyword in `define-pretty`, and as a result the `#:let` keyword isn't needed anymore either. This makes `define-pretty` macro uses a bit more readable, since they can now use ordinary default function arguments and ordinary local definitions. --- conventions.rkt | 33 +++++++++++++-------------------- core.rkt | 23 +++++++++++------------ 2 files changed, 24 insertions(+), 32 deletions(-) diff --git a/conventions.rkt b/conventions.rkt index 0a769f8..245e411 100644 --- a/conventions.rkt +++ b/conventions.rkt @@ -65,12 +65,10 @@ [(? visible?) (loop xs (sub1 pos) (cons (format-kw-arg x) acc))] [_ (loop xs pos (cons (pretty x) acc))])])]))) -(define-pretty (format-vertical/helper #:body-formatter [format-body #f] - #:kw-arg-formatter [format-kw-arg #f] +(define-pretty (format-vertical/helper #:body-formatter [format-body pretty] + #:kw-arg-formatter [format-kw-arg pretty] #:kw-map [kw-map default-kw-map]) #:type list? - #:default [format-body pretty] - #:default [format-kw-arg pretty] (let loop ([xs doc]) (define (v-append-if x xs) @@ -106,12 +104,10 @@ [(list x xs ...) (v-append-if (format-body x) xs)]))) ;; failable -(define-pretty (format-horizontal/helper #:body-formatter [format-body #f] - #:kw-arg-formatter [format-kw-arg #f] +(define-pretty (format-horizontal/helper #:body-formatter [format-body pretty] + #:kw-arg-formatter [format-kw-arg pretty] #:kw-map [kw-map default-kw-map]) #:type list? - #:default [format-body pretty] - #:default [format-kw-arg pretty] (flatten (let loop ([xs doc]) @@ -153,10 +149,10 @@ (define-pretty format-#%app #:type node? - #:let [xs (filter-not newl? (node-content doc))] - #:let [doc (struct-copy node doc [content xs])] + (define xs (filter-not newl? (node-content doc))) + (define doc-without-newlines (struct-copy node doc [content xs])) (cond - [((current-app?) doc) + [((current-app?) doc-without-newlines) (match/extract xs #:as unfits tail ;; mostly vertical [([-head #f]) @@ -175,7 +171,8 @@ ((format-horizontal/helper) (cons -head tail))))] [_ ;; pretty cases - ((format-if-like/helper #:expel-first-comment? #f #:adjust #f (λ (d) fail)) doc)]))] + ((format-if-like/helper #:expel-first-comment? #f #:adjust #f (λ (d) fail)) + doc-without-newlines)]))] ;; perhaps full of comments, or there's nothing at all [#:else (pretty-node #:adjust #f (try-indent #:n 0 #:because-of xs ((format-vertical/helper) xs)))])] @@ -189,13 +186,11 @@ (flatten (as-concat (map pretty xs))))))])) (define-pretty (format-uniform-body/helper n - #:arg-formatter [format-arg #f] - #:body-formatter [format-body #f] + #:arg-formatter [format-arg pretty] + #:body-formatter [format-body pretty] #:require-body? [require-body? #t] #:kw-map [kw-map default-kw-map]) #:type node? - #:default [format-arg pretty] - #:default [format-body pretty] (match (extract (node-content doc) (append (make-list n #t) (list #f))) ;; don't care [#f (format-#%app doc)] @@ -283,9 +278,8 @@ b) #;(define (foo) 111111111111111111111111111111111) -(define-pretty (format-define #:head-formatter [format-head #f]) +(define-pretty (format-define #:head-formatter [format-head pretty]) #:type node? - #:default [format-head pretty] (match/extract (node-content doc) #:as unfits tail [([-define #t] [-head #f]) ;; general case @@ -315,9 +309,8 @@ #;(define-values (xxxxxxxxxxx yyyyyyyyyyy) 1) #;(define-values (xxxxxxxxxxx yyyyyyyyyyy) 11111111111111111111111111111111111111111111111111111111111111111111111) -(define-pretty (format-define-like #:head-formatter [format-head #f]) +(define-pretty (format-define-like #:head-formatter [format-head pretty]) #:type node? - #:default [format-head pretty] (match/extract (node-content doc) #:as unfits tail [([-define #t] [-head #f]) ;; general case diff --git a/core.rkt b/core.rkt index c3be5ac..a527725 100644 --- a/core.rkt +++ b/core.rkt @@ -113,8 +113,13 @@ [_ (<$> (v-concat (map (unbox current-pretty) unfits)) doc*)])) (define current-pretty (box #f)) -(define-syntax-parameter pretty - (λ (stx) (raise-syntax-error #f "use of pretty outside its context" stx))) + +(define (pretty d) + (define pretty-proc (unbox current-pretty)) + (unless pretty-proc + (raise-arguments-error 'pretty "pretty can only be called during formatting")) + (pretty-proc d)) + (define-syntax-parameter doc (λ (stx) (raise-syntax-error #f "use of doc outside its context" stx))) (begin-for-syntax @@ -125,19 +130,13 @@ (define-syntax-parse-rule (define-pretty head:header #:type p? - {~seq #:default [from:id to]} ... - {~seq #:let [a:id b]} ... body ...+) #:with ooo (quote-syntax ...) (define (head d) - (let ([pretty-proc (unbox current-pretty)]) - (cond - [(p? d) - (syntax-parameterize ([pretty (make-rename-transformer #'pretty-proc)] - [doc (make-rename-transformer #'d)]) - (let* ([from (or from to)] ... [a b] ...) - body ...))] - [else (raise-argument-error 'head.name (symbol->string 'p?) d)])))) + (unless (p? d) + (raise-argument-error 'head.name (symbol->string 'p?) d)) + (syntax-parameterize ([doc (make-rename-transformer #'d)]) + body ...))) (define-syntax-parse-rule (pretty-node args ...) (pretty-node* doc args ...))