diff --git a/common.rkt b/common.rkt index 50ef94f..c1b3a62 100644 --- a/common.rkt +++ b/common.rkt @@ -1,3 +1,5 @@ +;; This file defines units for formatting + #lang racket/base (provide (struct-out thing) @@ -6,7 +8,7 @@ (struct-out node) (struct-out atom) (struct-out full-atom) - (struct-out nl) + (struct-out newl) (struct-out line-comment) (struct-out sexp-comment) (struct-out wrapper) @@ -20,7 +22,7 @@ (struct atom visible (content type) #:transparent) (struct full-atom atom () #:transparent) ;; invariant: n >= 1 -(struct nl thing (n) #:transparent) +(struct newl thing (n) #:transparent) (struct line-comment thing (content) #:transparent) ;; when style is 'disappeared or 'any, content must have length exactly one (struct sexp-comment commentable (style tok content) #:transparent) diff --git a/conventions.rkt b/conventions.rkt index e38a043..e5349a7 100644 --- a/conventions.rkt +++ b/conventions.rkt @@ -1,3 +1,5 @@ +;; This file defines various styles for code formatting + #lang racket/base (provide standard-formatter-map @@ -29,7 +31,7 @@ (require racket/match racket/list - pprint-compact + (except-in pretty-expressive flatten) "core.rkt" "common.rkt" "params.rkt" @@ -74,26 +76,31 @@ (define (v-append-if x xs) (match xs ['() x] - [_ (v-append x (loop xs))])) + [_ (<$> x (loop xs))])) (match xs ['() empty-doc] [(list (and dot (atom _ "." 'other)) x (and another-dot (atom _ "." 'other)) xs ...) - (v-append-if (alt (hs-append (pretty dot) (format-body x) (pretty another-dot)) - (v-append (pretty dot) (format-body x) (pretty another-dot))) + (define dot-formatted (pretty dot)) + (define x-formatted (format-body x)) + (define another-dot-formatted (pretty another-dot)) + (v-append-if (alt (flat ( dot-formatted x-formatted another-dot-formatted)) + (<$> dot-formatted x-formatted another-dot-formatted)) xs)] [(list (and dot (atom _ "." 'other)) x xs ...) - (v-append-if (alt (hs-append (pretty dot) (format-body x)) - (v-append (pretty dot) (format-body x))) + (define dot-formatted (pretty dot)) + (define x-formatted (format-body x)) + (v-append-if (<> dot-formatted (group nl) (align x-formatted)) xs)] [(list x (and ellipsis (atom _ (? (current-ellipsis?)) 'symbol)) xs ...) - (v-append-if (alt (hs-append (format-body x) (pretty ellipsis)) - (v-append (format-body x) (pretty ellipsis))) + (define body-formatted (format-body x)) + (define ellipsis-formatted (pretty ellipsis)) + (v-append-if (<> body-formatted (group nl) ellipsis-formatted) xs)] [(list (and kw (atom _ content 'hash-colon-keyword)) xs ...) ((format-kw-args kw (kw-map content xs) - (λ (xs docs) (v-append-if (alt (hs-concat docs) (v-concat docs)) xs)) + (λ (xs docs) (v-append-if (alt (v-concat docs) (as-concat docs)) xs)) format-kw-arg) xs)] [(list x xs ...) (v-append-if (format-body x) xs)]))) @@ -110,53 +117,64 @@ (define (h-append-if x xs) (match xs ['() x] - [_ (hs-append x (loop xs))])) + [_ ( x (loop xs))])) (match xs ['() empty-doc] [(list (and kw (atom _ content 'hash-colon-keyword)) xs ...) ((format-kw-args kw (kw-map content xs) - (λ (xs docs) (h-append-if (hs-concat docs) xs)) + (λ (xs docs) (h-append-if (as-concat docs) xs)) format-kw-arg) xs)] [(list x xs ...) (h-append-if (format-body x) xs)])))) -(define-pretty (format-if-like/helper format-else #:adjust [adjust '("(" ")")]) +(define-pretty (format-if-like/helper format-else + #:expel-first-comment? [expel-first-comment? #t] + #:adjust [adjust '("(" ")")]) #:type node? (match/extract (node-content doc) #:as unfits tail - [([-if #t] [-conditional #f]) + [([-if expel-first-comment?] [-conditional #f]) (pretty-node #:unfits unfits #:adjust adjust - (hs-append (flat (pretty -if)) - (try-indent #:n 0 - #:because-of (cons -conditional tail) - ;; try to fit in one line - #;(if a b c) - (alt (flat (hs-concat (map pretty (cons -conditional tail)))) - ;; or multiple lines - #;(if aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa - bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb - ccccccccccccccccccccccccccccccccc) - ((format-vertical/helper) (cons -conditional tail))))))] + ( (flat (pretty -if)) + (align (try-indent #:n 0 + #:because-of (cons -conditional tail) + ;; multiple lines + #;(if aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb + ccccccccccccccccccccccccccccccccc) + (alt ((format-vertical/helper) (cons -conditional tail)) + ;; or one line + #;(if a b c) + (flat (as-concat (map pretty (cons -conditional tail)))))))))] [#:else (format-else doc)])) (define-pretty format-#%app #:type node? - #:let [xs (filter-not nl? (node-content doc))] + #:let [xs (filter-not newl? (node-content doc))] #:let [doc (struct-copy node doc [content xs])] (cond [((current-app?) doc) (match/extract xs #:as unfits tail ;; mostly vertical [([-head #f]) - (alt (pretty-node #:unfits unfits - #:adjust #f - (try-indent #:n 0 - #:because-of (cons -head tail) - ((format-vertical/helper) (cons -head tail)))) - ;; pretty cases - ((format-if-like/helper #:adjust #f (λ (d) fail)) doc))] + (alt (cost '(0 0 1) + (pretty-node #:unfits unfits + #:adjust #f + (try-indent #:n 0 + #:because-of (cons -head tail) + ((format-vertical/helper) (cons -head tail))))) + (match tail + [(list (atom _ (? (current-ellipsis?)) 'symbol) _ ...) + (pretty-node #:unfits unfits + #:adjust #f + (try-indent #:n 0 + #:because-of (cons -head tail) + ((format-horizontal/helper) (cons -head tail))))] + [_ + ;; pretty cases + ((format-if-like/helper #:expel-first-comment? #f #:adjust #f (λ (d) fail)) doc)]))] ;; 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)))])] @@ -167,7 +185,7 @@ ;; general case (alt ((format-vertical/helper) xs) ;; try to fit in one line - (flat (hs-concat (map pretty xs))))))])) + (flat (as-concat (map pretty xs))))))])) (define-pretty (format-uniform-body/helper n #:arg-formatter [format-arg #f] @@ -187,7 +205,7 @@ ['() (pretty -macro-name)] [_ (define args (map format-arg -e)) - (hs-append (pretty -macro-name) (alt (flat (hs-concat args)) (v-concat args)))])) + ( (pretty -macro-name) (align (alt (v-concat args) (flat (as-concat args)))))])) (pretty-node #:unfits unfits (try-indent @@ -197,18 +215,23 @@ #:when (not require-body?) first-line] [_ - (v-append first-line - (h-append space - ((format-vertical/helper #:body-formatter format-body #:kw-map kw-map) - tail)))])))])) + (<$> first-line + (<> space + (align ((format-vertical/helper #:body-formatter format-body #:kw-map kw-map) + tail))))])))])) (define-pretty (format-clause-2/indirect #:kw-map [kw-map default-kw-map] #:flat? [flat? #t]) #:type values (match doc [(node _ (or "(" "[") (or ")" "]") #f #f xs) - ;; try to fit in one line; only when there are exactly two things - #;[a b] - (alt (match/extract xs #:as unfits tail + ;; general case + (alt (cost '(0 0 1) + (pretty-node + #:adjust '("[" "]") + (try-indent #:n 0 #:because-of xs ((format-vertical/helper #:kw-map kw-map) xs)))) + ;; try to fit in one line; only when there are exactly two things + #;[a b] + (match/extract xs #:as unfits tail [([-head #t] [-something #f]) (match tail ['() @@ -216,14 +239,10 @@ #:unfits unfits (try-indent #:n 0 #:because-of (list -something) - (let ([line (hs-append (pretty -head) (pretty -something))]) + (let ([line ( (flat (pretty -head)) (align (pretty -something)))]) (if flat? (flat line) line))))] [_ fail])] - [#:else fail]) - ;; general case - (pretty-node - #:adjust '("[" "]") - (try-indent #:n 0 #:because-of xs ((format-vertical/helper #:kw-map kw-map) xs))))] + [#:else fail]))] [_ (pretty doc)])) (define-pretty format-binding-pairs/indirect @@ -234,10 +253,10 @@ (try-indent #:n 0 #:because-of xs - ;; try to fit in one line - (alt ((format-horizontal/helper #:body-formatter (format-clause-2/indirect #:flat? #f)) xs) - ;; general case - ((format-vertical/helper #:body-formatter (format-clause-2/indirect #:flat? #f)) xs))))] + ;; general case + (alt ((format-vertical/helper #:body-formatter (format-clause-2/indirect #:flat? #f)) xs) + ;; try to fit in one line + ((format-horizontal/helper #:body-formatter (format-clause-2/indirect #:flat? #f)) xs))))] [_ (pretty doc)])) (define format-if (format-if-like/helper format-#%app)) @@ -256,9 +275,15 @@ #:default [format-head pretty] (match/extract (node-content doc) #:as unfits tail [([-define #t] [-head #f]) - ;; fit in one line case; only when there are either two or three things - #;(define a b) - (alt (pretty-node + ;; general case + #;(define (a b) + c + d + e) + (alt ((format-uniform-body/helper 1 #:arg-formatter format-head) doc) + ;; fit in one line case; only when there are either two or three things + #;(define a b) + (pretty-node #:unfits unfits (try-indent #:because-of tail @@ -266,15 +291,9 @@ [(? node?) fail] [_ (match tail - ['() (hs-append (pretty -define) (format-head -head))] - [(list -e) (hs-append (pretty -define) (format-head -head) (pretty -e))] - [_ fail])])))) - ;; general case - #;(define (a b) - c - d - e) - ((format-uniform-body/helper 1 #:arg-formatter format-head) doc))] + ['() ( (pretty -define) (format-head -head))] + [(list -e) ( (pretty -define) (format-head -head) (pretty -e))] + [_ fail])])))))] [#:else (format-#%app doc)])) ;; try to fit in one line if the body has exactly one form, @@ -287,22 +306,22 @@ #:default [format-head pretty] (match/extract (node-content doc) #:as unfits tail [([-define #t] [-head #f]) - ;; fit in one line case; only when there are either two or three things - #;(define a b) - (alt (pretty-node + ;; general case + #;(define (a b) + c + d + e) + (alt ((format-uniform-body/helper 1 #:arg-formatter format-head) doc) + ;; fit in one line case; only when there are either two or three things + #;(define a b) + (pretty-node #:unfits unfits (try-indent #:because-of tail (flat (match tail - ['() (hs-append (pretty -define) (format-head -head))] - [(list -e) (hs-append (pretty -define) (format-head -head) (pretty -e))] - [_ fail])))) - ;; general case - #;(define (a b) - c - d - e) - ((format-uniform-body/helper 1 #:arg-formatter format-head) doc))] + ['() ( (pretty -define) (format-head -head))] + [(list -e) ( (pretty -define) (format-head -head) (pretty -e))] + [_ fail])))))] [#:else (format-#%app doc)])) ;; this is similar to let*, but because the macro name is so long, @@ -311,14 +330,15 @@ #:type node? (match/extract (node-content doc) #:as unfits tail [([-parameterize #f] [-bindings #f]) - (alt (cost (pretty-node - #:unfits unfits - (v-append - (pretty -parameterize) - (h-append (text " ") (format-binding-pairs/indirect -bindings)) - (h-append space (try-indent #:because-of tail ((format-vertical/helper) tail))))) - 1) - (format-let* doc))] + (define bindings (align (format-binding-pairs/indirect -bindings))) + (<> (pretty-node + #:unfits unfits + (<> (pretty -parameterize) + (alt (cost '(0 0 3) (<> nl (text " ") bindings)) + (<> (text " ") bindings)) + nl + space + (align (try-indent #:because-of tail ((format-vertical/helper) tail))))))] [#:else (format-#%app doc)])) ;; unlike format-node-parameterize, don't allow the second form to be in its @@ -333,10 +353,10 @@ [([-let #t] [(? atom? -name) #t] [(? node? -bindings) #f]) (pretty-node #:unfits unfits (try-indent #:because-of tail - (v-append (hs-append (pretty -let) - (pretty -name) - (format-binding-pairs/indirect -bindings)) - (h-append space (v-concat (map pretty tail))))))] + (<$> ( (pretty -let) + (pretty -name) + (align (format-binding-pairs/indirect -bindings))) + (<> space (align (v-concat (map pretty tail)))))))] ;; regular let [#:else (format-let* doc)])) @@ -349,10 +369,10 @@ (match/extract (node-content doc) #:as unfits tail [([-provide #t] [-first-arg #f]) (pretty-node #:unfits unfits - (hs-append (flat (pretty -provide)) - (try-indent #:n 0 - #:because-of (cons -first-arg tail) - ((format-vertical/helper) (cons -first-arg tail)))))] + ( (flat (pretty -provide)) + (align (try-indent #:n 0 + #:because-of (cons -first-arg tail) + ((format-vertical/helper) (cons -first-arg tail))))))] [#:else (format-#%app doc)])) ;; support optional super id: either @@ -395,18 +415,18 @@ #:when (< (length groups) n) (loop kwds (cons -group groups) -tail*)] [_ - (values (apply hs-append + (values (apply (for/list ([p (in-list (reverse kwds))]) - (hs-append (pretty (car p)) (pretty (cdr p))))) + ( (align (pretty (car p))) (align (pretty (cdr p)))))) (for/list ([g (in-list (reverse groups))]) (format-binding-pairs/indirect g)) - (h-append space ((format-vertical/helper) tail)))]))) + (<> space (align ((format-vertical/helper) tail))))]))) (define first-line - (hs-append (pretty -for-name) - (v-append kwds (alt (flat (hs-concat groups)) (v-concat groups))))) + ( (pretty -for-name) + (align (<$> kwds (alt (v-concat groups) (flat (as-concat groups))))))) (pretty-node #:unfits unfits - (try-indent #:because-of (list* -for-name -kwd tail) (v-append first-line body)))] + (try-indent #:because-of (list* -for-name -kwd tail) (<$> first-line body)))] [#:else ((format-uniform-body/helper n #:arg-formatter format-binding-pairs/indirect) doc)])) (define/record standard-formatter-map #:record all-kws @@ -453,6 +473,8 @@ [("test-case" "test-suite") (format-uniform-body/helper 1)] [("define-syntax-class" "define-match-expander") (format-uniform-body/helper 1)] [("class") (format-uniform-body/helper 1 #:require-body? #f)] + [("interface") (format-uniform-body/helper 1 #:require-body? #f)] + [("interface*") (format-uniform-body/helper 2 #:require-body? #f)] [("module" "module*") (format-uniform-body/helper 2)] [("cond" "case-lambda" "match-lambda" "match-lambda*" "match-lambda**") diff --git a/core.rkt b/core.rkt index 96826c7..e581b55 100644 --- a/core.rkt +++ b/core.rkt @@ -1,3 +1,5 @@ +;; This file defines the core of code formatter + #lang racket/base (provide pretty-doc @@ -13,18 +15,19 @@ try-indent) (require racket/match + racket/string racket/list racket/stxparam syntax/parse/define - pprint-compact - pprint-compact/memoize + (except-in pretty-expressive flatten) + (only-in (submod pretty-expressive/doc private) make-text) "common.rkt" (for-syntax racket/base syntax/parse/lib/function-header)) (define (extract xs extract-configs) (let loop ([xs xs] [extract-configs extract-configs] [fits '()] [unfits '()]) (match extract-configs - ['() (list (reverse fits) (filter-not nl? (reverse unfits)) xs)] + ['() (list (reverse fits) (filter-not newl? (reverse unfits)) xs)] [(cons extract-config extract-configs) (match xs ['() #f] @@ -41,15 +44,25 @@ [else (loop xs (cons extract-config extract-configs) fits (cons x unfits))])])]))) (define (pretty-comment comment d) - (if comment (full (hs-append d (text comment))) d)) + (if comment (full ( d (text comment))) d)) + +(define (memoize f #:backend [backend make-weak-hasheq]) + (define table (backend)) + (λ (x) (hash-ref! table x (λ () (f x))))) (define (pretty-doc xs hook) (define loop (memoize (λ (d) (match d - [(nl n) (full (v-concat (make-list n empty-doc)))] + [(newl n) (full (v-concat (make-list n empty-doc)))] [(full-atom _ content _) (full (text content))] - [(atom comment content _) (pretty-comment comment (text content))] + [(atom comment content type) + (pretty-comment + comment + (make-text content + (match type + ['block-comment (apply max (map string-length (string-split content "\n")))] + [_ (string-length content)])))] [(line-comment comment) (full (text comment))] [(node _ _ _ _ _ xs) (match (extract xs (list #f)) @@ -57,14 +70,14 @@ [(list (list (atom _ content 'symbol)) _ _) ((hook content) d)] [_ ((hook #f) d)])] [(wrapper comment tok content) - (pretty-comment comment (h-append (text tok) (loop content)))] + (pretty-comment comment (<> (text tok) (align (loop content))))] [(sexp-comment comment style tok xs) (pretty-comment comment (match style - ['newline (v-append (text tok) (v-concat (map loop xs)))] + ['newline (apply <$> (text tok) (map loop xs))] ['any (define :x (loop (first xs))) - (alt (h-append (text tok) :x) (v-append (text tok) :x))] + (alt (<$> (text tok) :x) (<> (text tok) (align :x)))] ['disappeared (loop (first xs))]))])))) (set-box! current-pretty loop) (begin0 (v-concat (map loop xs)) @@ -74,16 +87,17 @@ (match-define (node comment opener closer prefix breakable-prefix _) the-node) (define doc (pretty-comment comment - (h-append (text (string-append (or prefix "") (if adjust (first adjust) opener))) - d - (text (if adjust (second adjust) closer))))) + (<> (text (string-append (or prefix "") (if adjust (first adjust) opener))) + (align d) + (text (if adjust (second adjust) closer))))) (define doc* (if breakable-prefix - (alt (h-append (text breakable-prefix) doc) (v-append (text breakable-prefix) doc)) + (alt (<$> (text breakable-prefix) doc) + (<> (text breakable-prefix) (align doc))) doc)) (match unfits ['() doc*] - [_ (v-append (v-concat (map (unbox current-pretty) unfits)) doc*)])) + [_ (<$> (v-concat (map (unbox current-pretty) unfits)) doc*)])) (define current-pretty (box #f)) (define-syntax-parameter pretty @@ -115,18 +129,24 @@ (define-syntax-parse-rule (pretty-node args ...) (pretty-node* doc args ...)) +(define spaces-table (make-hasheq)) + +(define (spaces n) + (hash-ref! spaces-table n + (λ () (text (make-string n #\space))))) + (define (require-newline? d) - (or (and (commentable? d) (commentable-inline-comment d)) (line-comment? d) (nl? d) (full-atom? d))) + (or (and (commentable? d) (commentable-inline-comment d)) (line-comment? d) (newl? d) (full-atom? d))) (define (try-indent d #:n [n 1] #:because-of xs) (match xs ['() d] - [_ (if (require-newline? (last xs)) (indent-next n d) d)])) + [_ (if (require-newline? (last xs)) (<$> d (spaces n)) d)])) (define-syntax-parser match/extract - [(_ xs #:as unfits tail [([pat req-status:boolean] ...) body ...+] . rst) + [(_ xs #:as unfits tail [([pat req-status] ...) body ...+] . rst) #'(let ([-xs xs]) - (match (extract -xs '(req-status ...)) + (match (extract -xs (list req-status ...)) [(list (list pat ...) unfits tail) body ...] [_ diff --git a/for-profiling.rkt b/for-profiling.rkt index 3688878..051790e 100644 --- a/for-profiling.rkt +++ b/for-profiling.rkt @@ -1,3 +1,5 @@ +;; An entry suitable for raco profile + #lang racket (module+ main diff --git a/info.rkt b/info.rkt index c0c35ef..ed063d1 100644 --- a/info.rkt +++ b/info.rkt @@ -1,12 +1,12 @@ #lang info (define collection "fmt") -(define deps '(["pprint-compact" #:version "0.0.1"] +(define deps '("pretty-expressive" "syntax-color-lib" "base")) (define build-deps '("scribble-lib" "racket-doc" "rackunit-lib")) (define scribblings '(("scribblings/fmt.scrbl" ()))) (define pkg-desc "an extensible code formatter for Racket") -(define version "0.0.1") +(define version "0.0.2") (define pkg-authors '(sorawee)) (define license '(Apache-2.0 OR MIT)) (define compile-omit-files '("tests" "scribblings/examples" "experiments")) diff --git a/main.rkt b/main.rkt index bf773d2..47d4dc9 100644 --- a/main.rkt +++ b/main.rkt @@ -1,5 +1,9 @@ +;; The main file for fmt + #lang racket/base +(define-logger fmt) + (provide program-format empty-formatter-map compose-formatter-map @@ -14,7 +18,8 @@ (require racket/string racket/contract racket/format - pprint-compact + racket/match + (except-in pretty-expressive flatten) "common.rkt" "core.rkt" "read.rkt" @@ -28,17 +33,48 @@ #:formatter-map [formatter-map empty-formatter-map] #:source [source #f] #:width [width (current-width)] + #:limit [limit (current-limit)] #:max-blank-lines [max-blank-lines (current-max-blank-lines)] #:indent [indent (current-indent)]) (define doc (realign (read-all program-source source max-blank-lines))) - (define s - (pretty-format - #:width width - #:indent indent - (pretty-doc doc - (compose-formatter-map formatter-map standard-formatter-map)))) - - (string-join (for/list ([line (in-list (string-split s "\n"))]) + (match-define-values [(list s) _ real _] + (time-apply + (λ () + (pretty-format/factory + (pretty-doc doc (compose-formatter-map formatter-map standard-formatter-map)) + (cost-factory + (match-lambda** + [((list b1 h1 c1) (list b2 h2 c2)) + (cond + [(= b1 b2) + (cond + [(= h1 h2) (<= c1 c2)] + [else (< h1 h2)])] + [else (< b1 b2)])]) + (match-lambda** + [((list b1 h1 c1) (list b2 h2 c2)) + (list (+ b1 b2) (+ h1 h2) (+ c1 c2))]) + (λ (c l) + (define stop (+ c l)) + (cond + [(> stop width) + (define start (max width c)) + (define a (- start width)) + (define b (- stop start)) + (list (* b (+ (* 2 a) b)) 0 0)] + [else (list 0 0 0)])) + (λ (i) (list 0 1 0)) + limit) + #:offset indent)) + '())) + + (define all-lines (string-split s "\n")) + + (log-fmt-debug "([duration ~a] [lines ~a])" + (exact->inexact (/ real 1000)) + (length all-lines)) + + (string-join (for/list ([line (in-list all-lines)]) (string-trim line #:left? #f)) "\n")) diff --git a/params.rkt b/params.rkt index 40990a2..5236810 100644 --- a/params.rkt +++ b/params.rkt @@ -1,8 +1,11 @@ +;; This file defines various parameters of fmt + #lang racket/base (provide current-width current-max-blank-lines current-indent + current-limit current-app? current-ellipsis?) @@ -11,6 +14,7 @@ "common.rkt") (define current-width (make-parameter 102)) +(define current-limit (make-parameter 120)) (define current-max-blank-lines (make-parameter 1)) (define current-indent (make-parameter 0)) (define current-app? diff --git a/raco.rkt b/raco.rkt index 07b85c2..90b4b31 100644 --- a/raco.rkt +++ b/raco.rkt @@ -1,3 +1,5 @@ +;; An entry point of raco fmt + #lang racket/base ; don't run this file for testing: @@ -10,7 +12,8 @@ (rename-in "main.rkt" [current-width :current-width] [current-max-blank-lines :current-max-blank-lines] - [current-indent :current-indent])) + [current-indent :current-indent] + [current-limit :current-limit])) (define current-width (make-parameter @@ -18,11 +21,24 @@ (λ (n) (define as-num (string->number n)) (cond - [(and as-num (or (exact-nonnegative-integer? as-num) (= as-num +inf.0))) + [(and as-num (exact-nonnegative-integer? as-num)) as-num] [else (raise-user-error 'width - "must be either a natural number or +inf.0, given: ~a" + "must be a natural number, given: ~a" + n)])))) + +(define current-limit + (make-parameter + (:current-limit) + (λ (n) + (define as-num (string->number n)) + (cond + [(and as-num (exact-nonnegative-integer? as-num)) + as-num] + [else (raise-user-error + 'width + "must be a natural number, given: ~a" n)])))) (define current-max-blank-lines @@ -59,8 +75,12 @@ #:once-each [("--width") w - "page width limit -- must be a natural number or +inf.0 (default: 80)" + "page width limit -- must be a natural number (default: 102)" (current-width w)] + [("--limit") + W + "computation width limit -- must be a natural number (default: 120)" + (current-limit W)] [("--max-blank-lines") n "max consecutive blank lines -- must be a natural number or +inf.0 (default: 1)" @@ -92,6 +112,7 @@ (program-format s #:formatter-map the-map #:width (current-width) + #:limit (current-limit) #:max-blank-lines (current-max-blank-lines))) (define (do-format s) diff --git a/read.rkt b/read.rkt index 51bd2be..233fe3a 100644 --- a/read.rkt +++ b/read.rkt @@ -1,3 +1,5 @@ +;; The read pass + #lang racket/base (provide read-all @@ -76,7 +78,7 @@ [(equal? closer-sym closer) (define-values (this xs*) (process-tail - (node #f open-paren closer-text #f #f (dropf (reverse (dropf acc nl?)) nl?)) + (node #f open-paren closer-text #f #f (dropf (reverse (dropf acc newl?)) newl?)) xs)) (values (done this) xs*)] [else @@ -104,7 +106,7 @@ [(cons (token _ _ `(white-space 1)) xs) (read-one xs #:on-eof on-eof #:on-closer on-closer)] - [(cons (token _ _ `(white-space ,n)) xs) (values (nl (sub1 n)) xs)] + [(cons (token _ _ `(white-space ,n)) xs) (values (newl (sub1 n)) xs)] [(cons (token _ (and c (or "'" "`" "#'" "#`")) 'constant) xs) (values (bare-prefix c) xs)] @@ -124,7 +126,7 @@ (let loop ([xs xs] [acc '()]) (define-values (this xs*) (read-one xs #:on-eof (λ () (values 'eof '())))) (cond - [(eq? 'eof this) (reverse (dropf acc nl?))] + [(eq? 'eof this) (reverse (dropf acc newl?))] [else (loop xs* (cons this acc))]))) (define (read-all program-source max-blank-lines source) diff --git a/realign.rkt b/realign.rkt index 938d712..9af6e9b 100644 --- a/realign.rkt +++ b/realign.rkt @@ -1,3 +1,5 @@ +;; A tree fix up + #lang racket/base (provide realign) @@ -12,11 +14,11 @@ (let loop ([xs xs] [just-read-sexp-comment? #f]) (match xs ['() '()] - [(cons (? nl? d) xs) (cons d (loop xs #f))] + [(cons (? newl? d) xs) (cons d (loop xs #f))] [(cons (? atom? d) xs) (cons d (loop xs #f))] [(cons (? line-comment? d) xs) (cons d (loop xs #f))] [(cons (? bare-sexp-comment?) xs) - (define-values (invisibles tail) (splitf-at (loop (dropf xs nl?) #t) (negate visible?))) + (define-values (invisibles tail) (splitf-at (loop (dropf xs newl?) #t) (negate visible?))) (match tail ['() (raise-read-error "sexp-comment without content" #f #f #f #f #f)] [(cons visible xs) @@ -53,7 +55,7 @@ xs)])])] [(cons (bare-prefix tk) xs) - (define-values (invisibles tail) (splitf-at (loop (dropf xs nl?) #f) (negate visible?))) + (define-values (invisibles tail) (splitf-at (loop (dropf xs newl?) #f) (negate visible?))) (match tail ['() (raise-read-error "quote without content" #f #f #f #f #f)] [(cons visible xs) diff --git a/regen.rkt b/regen.rkt index bf025e9..945fc97 100644 --- a/regen.rkt +++ b/regen.rkt @@ -3,11 +3,13 @@ (require file/glob) (module+ main - (define to-self '("conventions.rkt" "core.rkt")) + (define to-self #;'("conventions.rkt" "core.rkt") + '()) (define to-out (flatten (map glob '("tests/*.rkt")))) (for ([f to-self]) (system (format "raco fmt -i ~a" (~a f)))) (for ([f to-out]) + (printf "formatting ~a\n" f) (system (format "raco fmt ~a > ~a.out" (~a f) (~a f))))) diff --git a/scribblings/fmt.scrbl b/scribblings/fmt.scrbl index 0c99e1e..bdf2ba1 100644 --- a/scribblings/fmt.scrbl +++ b/scribblings/fmt.scrbl @@ -8,7 +8,7 @@ racket/string racket/contract fmt - pprint-compact] + pretty-expressive] @for-syntax[racket/base]] @(define evaluator (make-base-eval)) @@ -22,7 +22,7 @@ This package provides a tool @exec{raco fmt} to reformat Racket code. -The package uses @racketmodname[pprint-compact], a very expressive pretty printer library, to compute the most optimal layout of the output code, and uses @racketmodname[syntax-color/module-lexer #:indirect] to lex the input program. +The package uses @racketmodname[pretty-expressive], a very expressive pretty printer library, to compute the most optimal layout of the output code, and uses @racketmodname[syntax-color/module-lexer #:indirect] to lex the input program. The interface to allow users to extend formatting style is extremely unstable and is still a work in progress. For now, the only thing that is stable is the command @exec{raco fmt}. @@ -160,7 +160,7 @@ which means the @tech{formatter map} wants to let other fallback @item{@racketmodname[racket/pretty] (by the Racket team) is a library for pretty printing an S-expression value. It does not support comments, is less expressive and less optimal than @racketmodname[fmt].} @item{@racketmodname[pprint #:indirect] (by @link["http://calculist.org/"]{Dave Herman} and @link["https://www.asumu.xyz/"]{Asumu Takikawa}) is a library for pretty printing an arbitrary document. - It is based on Wadler's pretty printer, which is less expressive and less optimal than @racketmodname[pprint-compact] + It is based on Wadler/Leijen's pretty printer, which is less expressive and less optimal than @racketmodname[pretty-expressive] (but has better performance).} @item{@link["https://github.com/Shuumatsu/racket-pretty-printer/"]{@tt{racket-pretty-printer}} (by @link["https://github.com/Shuumatsu"]{为世人降下祝福}) is a Racket formatter written in Haskell. It uses Wadler's pretty printer, so it has the limitations as described in the above item.} diff --git a/scribblings/kws.rkt b/scribblings/kws.rkt index 700b375..2a68c77 100644 --- a/scribblings/kws.rkt +++ b/scribblings/kws.rkt @@ -3,7 +3,7 @@ (provide get-kws) (require racket/match - pprint-compact + pretty-expressive (only-in fmt/conventions all-kws)) (define (flow xs) @@ -17,8 +17,8 @@ (define elem (text x)) (loop xs (alt (v-append acc elem) - (hs-append acc elem)))]))])) + (as-append acc elem)))]))])) (define (get-kws) (define xs (sort all-kws stringlist (syntax (id ...))) (loop (cdr l)))] - [_else (loop (cdr l))])))] + [private-field-names (let loop ([l exprs]) + (if (null? l) + null + (syntax-case (car l) (define-values) + [(define-values (id ...) expr) + (append (syntax->list (syntax (id ...))) + (loop (cdr l)))] + [_else (loop (cdr l))])))] [init-mode (cond [(null? init-rest-decls) 'normal] [(stx-null? (stx-cdr (car init-rest-decls))) 'stop] @@ -1103,19 +1106,19 @@ (let ([check-dup (lambda (what l) (let ([ht (make-hasheq)]) - (for-each - (lambda (id) - (define key - (let ([l-id (lookup-localize id)]) - (if (identifier? l-id) - (syntax-e l-id) - ;; For a given localized id, `lookup-localize` - ;; will return the same (eq?) value - l-id))) - (when (hash-ref ht key #f) - (bad (format "duplicate declared external ~a name" what) id)) - (hash-set! ht key #t)) - l)))]) + (for-each (lambda (id) + (define key + (let ([l-id (lookup-localize id)]) + (if (identifier? l-id) + (syntax-e l-id) + ;; For a given localized id, `lookup-localize` + ;; will return the same (eq?) value + l-id))) + (when (hash-ref ht key #f) + (bad (format "duplicate declared external ~a name" what) + id)) + (hash-set! ht key #t)) + l)))]) ;; method names (check-dup "method" (map cdr @@ -1275,16 +1278,16 @@ ;; ---- set up field and method mappings ---- (with-syntax ([(rename-super-orig ...) (definify (map car rename-supers))] - [(rename-super-orig-localized ...) - (map lookup-localize (map car rename-supers))] + [(rename-super-orig-localized ...) (map lookup-localize + (map car rename-supers))] [(rename-super-extra-orig ...) (map car rename-super-extras)] [(rename-super-temp ...) (definify (generate-temporaries (map car rename-supers)))] [(rename-super-extra-temp ...) (generate-temporaries (map car rename-super-extras))] [(rename-inner-orig ...) (definify (map car rename-inners))] - [(rename-inner-orig-localized ...) - (map lookup-localize (map car rename-inners))] + [(rename-inner-orig-localized ...) (map lookup-localize + (map car rename-inners))] [(rename-inner-extra-orig ...) (map car rename-inner-extras)] [(rename-inner-temp ...) (generate-temporaries (map car rename-inners))] [(rename-inner-extra-temp ...) @@ -1296,14 +1299,14 @@ [(pubment-name-localized ...) (map lookup-localize (map car pubments))] [(pubment-temp ...) (map mk-method-temp (map car pubments))] [(public-final-name ...) (map car public-finals)] - [(public-final-name-localized ...) - (map lookup-localize (map car public-finals))] + [(public-final-name-localized ...) (map lookup-localize + (map car public-finals))] [(public-final-temp ...) (map mk-method-temp (map car public-finals))] [(method-name ...) (append local-public-dynamic-names (map car all-inherits))] - [(method-name-localized ...) - (map lookup-localize - (append local-public-dynamic-names (map car all-inherits)))] + [(method-name-localized ...) (map lookup-localize + (append local-public-dynamic-names + (map car all-inherits)))] [(method-accessor ...) (generate-temporaries (append local-public-dynamic-names (map car all-inherits)))] @@ -1315,8 +1318,8 @@ inherit-field-names))] [(inherit-name ...) (definify (map car all-inherits))] [(inherit-field-name ...) (definify inherit-field-names)] - [(inherit-field-name-localized ...) - (map lookup-localize inherit-field-names)] + [(inherit-field-name-localized ...) (map lookup-localize + inherit-field-names)] [(local-field ...) (definify (append field-names private-field-names))] [(local-field-localized ...) (map lookup-localize (append field-names private-field-names))] @@ -1399,25 +1402,25 @@ (lambda (name) (ormap (lambda (m) - (and - (bound-identifier=? (car m) name) - (with-syntax ([proc (proc-shape (car m) - (cdr m) - #t - the-obj - the-finder - bad - class-name - expand-stop-names - def-ctx - lookup-localize)] - [extra-init-mappings extra-init-mappings]) - (syntax (syntax-parameterize - ([super-instantiate-param super-error-map] - [super-make-object-param super-error-map] - [super-new-param super-error-map]) - (letrec-syntaxes+values extra-init-mappings () - proc)))))) + (and (bound-identifier=? (car m) name) + (with-syntax ([proc (proc-shape (car m) + (cdr m) + #t + the-obj + the-finder + bad + class-name + expand-stop-names + def-ctx + lookup-localize)] + [extra-init-mappings extra-init-mappings]) + (syntax (syntax-parameterize + ([super-instantiate-param super-error-map] + [super-make-object-param super-error-map] + [super-new-param super-error-map]) + (letrec-syntaxes+values extra-init-mappings + () + proc)))))) methods)))] [lookup-localize-cdr (lambda (p) (lookup-localize (cdr p)))]) @@ -1433,11 +1436,11 @@ [augment-names (map lookup-localize-cdr augments)] [augment-final-names (map lookup-localize-cdr augment-finals)] [(rename-super-name ...) (map lookup-localize-cdr rename-supers)] - [(rename-super-extra-name ...) - (map lookup-localize-cdr rename-super-extras)] + [(rename-super-extra-name ...) (map lookup-localize-cdr + rename-super-extras)] [(rename-inner-name ...) (map lookup-localize-cdr rename-inners)] - [(rename-inner-extra-name ...) - (map lookup-localize-cdr rename-inner-extras)] + [(rename-inner-extra-name ...) (map lookup-localize-cdr + rename-inner-extras)] [inherit-names (map lookup-localize-cdr all-inherits)] [abstract-names (map lookup-localize-cdr abstracts)] [num-fields (datum->syntax (quote-syntax here) @@ -1462,8 +1465,8 @@ (map (find-method methods) (map car (append augments augment-finals augrides)))] [(pubment-method ...) (map (find-method methods) (map car pubments))] - [(public-final-method ...) - (map (find-method methods) (map car public-finals))] + [(public-final-method ...) (map (find-method methods) + (map car public-finals))] ;; store a dummy method body that should never be called for abstracts [(abstract-method ...) (map (lambda (abs) @@ -1535,14 +1538,14 @@ method-accessor ...) ; for a local call that needs a dynamic lookup (define-syntax-parameter the-finder #f) - (let ([local-field-accessor - (make-struct-field-accessor local-accessor - local-field-pos - #f)] ... - [local-field-mutator - (make-struct-field-mutator local-mutator - local-field-pos - #f)] ...) + (let ([local-field-accessor (make-struct-field-accessor + local-accessor + local-field-pos + #f)] ... + [local-field-mutator (make-struct-field-mutator + local-mutator + local-field-pos + #f)] ...) (syntax-parameterize ([this-param (make-this-map (quote-syntax this-id) (quote-syntax the-finder) @@ -1743,10 +1746,10 @@ (define-syntax (-define-serializable-class stx) (syntax-case stx () [(_ orig-stx name super-expression (interface-expr ...) defn-or-expr ...) - (let ([deserialize-name-info - (datum->syntax #'name - (string->symbol (format "deserialize-info:~a" (syntax-e #'name))) - #'name)]) + (let ([deserialize-name-info (datum->syntax #'name + (string->symbol (format "deserialize-info:~a" + (syntax-e #'name))) + #'name)]) (unless (memq (syntax-local-context) '(top-level module)) (raise-syntax-error #f "allowed only at the top level or within a module top level" @@ -1798,19 +1801,19 @@ (syntax-case stx () [(_ binding ...) (let ([bindings (syntax->list (syntax (binding ...)))]) - (let ([name-exprs (map (lambda (binding) - (syntax-case binding () - [(name expr) - (identifier? (syntax name)) - (cons (syntax name) (syntax expr))] - [_else - (identifier? (syntax name)) - (raise-syntax-error - #f - "expected an identifier and expression" - stx - binding)])) - bindings)]) + (let ([name-exprs + (map (lambda (binding) + (syntax-case binding () + [(name expr) + (identifier? (syntax name)) + (cons (syntax name) (syntax expr))] + [_else + (identifier? (syntax name)) + (raise-syntax-error #f + "expected an identifier and expression" + stx + binding)])) + bindings)]) (with-syntax ([(name ...) (map car name-exprs)] [(expr ...) (map cdr name-exprs)] [decl-form decl-form]) @@ -1880,11 +1883,11 @@ (define-syntaxes (id ...) (values (make-private-name (quote-syntax id) (quote-syntax gen-id)) ...)))]) - (class-syntax-protect - (syntax/loc stx - (begin - (define-values (gen-id ...) (values (generate-local-member-name 'id) ...)) - stx-defs)))))))])) + (class-syntax-protect (syntax/loc stx + (begin + (define-values (gen-id ...) + (values (generate-local-member-name 'id) ...)) + stx-defs)))))))])) (define-syntax (define-member-name stx) (syntax-case stx () @@ -2293,16 +2296,16 @@ last few projections. ;; ---- Make the class and its interface ---- (let* ([class-make (if name (make-naming-constructor struct:class name "class") make-class)] [interface-make (if name - (make-naming-constructor - struct:interface - (string->symbol (format "interface:~a" name)) - #f) + (make-naming-constructor struct:interface + (string->symbol (format "interface:~a" + name)) + #f) make-interface)] [method-names (append (reverse public-names) super-method-ids)] [field-names (append public-field-names super-field-ids)] ;; Superclass abstracts that have not been concretized - [remaining-abstract-names - (append abstract-names (remq* override-names super-abstract-ids))] + [remaining-abstract-names (append abstract-names + (remq* override-names super-abstract-ids))] [super-interfaces (cons (class-self-interface super) interfaces)] [i (interface-make name super-interfaces @@ -2458,27 +2461,27 @@ last few projections. ;; -- Extract superclass methods and make rename-inners --- (let ([rename-supers - (map (lambda (index mname) - ;; While the last part of the vector is indeed the right - ;; method, if there have been super contracts placed since, - ;; they won't be reflected there, only in the super-methods - ;; vector of the superclass. - (let ([vec (vector-ref (class-beta-methods super) index)]) - (when (and (positive? (vector-length vec)) - (not (vector-ref vec (sub1 (vector-length vec))))) - (obj-error - 'class* - (string-append - "superclass method for override, overment, inherit/super, " - "or rename-super is not overrideable") - "superclass" - super - "method name" - (as-write mname) - #:class-name name))) - (vector-ref (class-super-methods super) index)) - rename-super-indices - rename-super-names)] + (map + (lambda (index mname) + ;; While the last part of the vector is indeed the right + ;; method, if there have been super contracts placed since, + ;; they won't be reflected there, only in the super-methods + ;; vector of the superclass. + (let ([vec (vector-ref (class-beta-methods super) index)]) + (when (and (positive? (vector-length vec)) + (not (vector-ref vec (sub1 (vector-length vec))))) + (obj-error 'class* + (string-append + "superclass method for override, overment, inherit/super, " + "or rename-super is not overrideable") + "superclass" + super + "method name" + (as-write mname) + #:class-name name))) + (vector-ref (class-super-methods super) index)) + rename-super-indices + rename-super-names)] [rename-inners (let ([new-augonly (make-vector method-width #f)]) (define (get-depth index) @@ -2493,14 +2496,14 @@ last few projections. (let ([check-aug (lambda (maybe-here?) (lambda (mname index) - (let ([aug-ok? - (or (if (index . < . (class-method-width super)) - (eq? (vector-ref (class-meth-flags super) index) - 'augmentable) - #f) - (and maybe-here? - (or (memq mname pubment-names) - (memq mname overment-names))))]) + (let ([aug-ok? (or (if (index . < . (class-method-width super)) + (eq? (vector-ref (class-meth-flags super) + index) + 'augmentable) + #f) + (and maybe-here? + (or (memq mname pubment-names) + (memq mname overment-names))))]) (unless aug-ok? (obj-error 'class* @@ -2520,14 +2523,14 @@ last few projections. ;; Now that checking is done, add `augment': (for-each (lambda (id) (vector-set! new-augonly (hash-ref method-ht id) #t)) augment-names) - (map - (lambda (mname index) - (let ([depth (get-depth index)]) - (lambda (obj) - (vector-ref (vector-ref (class-beta-methods (object-ref obj)) index) - depth)))) - rename-inner-names - rename-inner-indices))]) + (map (lambda (mname index) + (let ([depth (get-depth index)]) + (lambda (obj) + (vector-ref (vector-ref (class-beta-methods (object-ref obj)) + index) + depth)))) + rename-inner-names + rename-inner-indices))]) ;; Have to update these before making the method-accessors, since this is a "static" piece ;; of information (instead of being dynamic => method call time). @@ -2544,9 +2547,9 @@ last few projections. (map (lambda (index) (let ([dyn-idx (vector-ref dynamic-idxs index)]) (lambda (obj) - (vector-ref - (vector-ref (class-int-methods (object-ref obj)) index) - dyn-idx)))) + (vector-ref (vector-ref (class-int-methods (object-ref obj)) + index) + dyn-idx)))) (append new-normal-indices replace-normal-indices refine-normal-indices @@ -2656,9 +2659,9 @@ last few projections. (for-each (lambda (id) (let ([index (hash-ref method-ht id)]) - (let ([v (list->vector - (append (vector->list (vector-ref beta-methods index)) - (list #f)))]) + (let ([v (list->vector (append (vector->list (vector-ref beta-methods + index)) + (list #f)))]) ;; Since this starts a new part of the chain, reset the projection. (vector-set! inner-projs index values) (vector-set! beta-methods index v)))) @@ -3271,15 +3274,15 @@ An example (vector-set! (class-supers object%) 0 object%) (set-class-orig-cls! object% object%) (let*-values ([(struct:obj make-obj obj? -get -set!) - (make-struct-type - 'object - #f - 0 - 0 - #f - (list (cons prop:object object%) - (cons prop:equal+hash (list object-equal? object-hash-code object-hash-code))) - #f)]) + (make-struct-type 'object + #f + 0 + 0 + #f + (list (cons prop:object object%) + (cons prop:equal+hash + (list object-equal? object-hash-code object-hash-code))) + #f)]) (set-class-struct:object! object% struct:obj) (set-class-make-object! object% make-obj)) (set-class-object?! object% object?) ; don't use struct pred; it wouldn't work with prim classes @@ -3712,24 +3715,24 @@ An example (set! let-bindings (reverse let-bindings)) (class-syntax-protect - (syntax-property - (quasisyntax/loc stx - (let*-values ([(sym) (quasiquote (unsyntax (localize name)))] - [(receiver) (unsyntax obj)] - [(method) (find-method/who '(unsyntax form) receiver sym)]) - (let (#,@(if kw-args (list #`[kw-arg-tmp #,(cadr kw-args)]) (list)) #,@let-bindings) - (unsyntax (make-method-call-to-possibly-wrapped-object - stx - kw-args/var - arg-list - rest-arg? - #'sym - #'method - #'receiver - (quasisyntax/loc stx - (find-method/who '(unsyntax form) receiver sym))))))) - 'feature-profile:send-dispatch - #t)))) + (syntax-property (quasisyntax/loc stx + (let*-values ([(sym) (quasiquote (unsyntax (localize name)))] + [(receiver) (unsyntax obj)] + [(method) (find-method/who '(unsyntax form) receiver sym)]) + (let (#,@(if kw-args (list #`[kw-arg-tmp #,(cadr kw-args)]) (list)) + #,@let-bindings) + (unsyntax (make-method-call-to-possibly-wrapped-object + stx + kw-args/var + arg-list + rest-arg? + #'sym + #'method + #'receiver + (quasisyntax/loc stx + (find-method/who '(unsyntax form) receiver sym))))))) + 'feature-profile:send-dispatch + #t)))) (define (core-send apply? kws?) (lambda (stx) @@ -4004,10 +4007,10 @@ An example (class-syntax-protect (syntax/loc stx (make class-expr `name)))))] [(_ class-expr) - (raise-syntax-error - #f - (format "expected a field name after the ~a expression" targets) - stx)])))]) + (raise-syntax-error #f + (format "expected a field name after the ~a expression" + targets) + stx)])))]) (values (mk (quote-syntax make-class-field-accessor) "class") (mk (quote-syntax make-class-field-mutator) "class") (mk (quote-syntax make-generic/proc) "class or interface")))) @@ -4151,9 +4154,9 @@ An example [(name ...) (map localize names)]) (class-syntax-protect (syntax/loc stx - (let-values ([(method method-obj) - (let ([obj obj-expr]) - (values (find-method/who 'with-method obj `name) obj))] ...) + (let-values ([(method method-obj) (let ([obj obj-expr]) + (values (find-method/who 'with-method obj `name) + obj))] ...) (letrec-syntaxes+values ([(id) (make-with-method-map (quote-syntax set!) (quote-syntax id) (quote-syntax method) @@ -4434,20 +4437,20 @@ An example (define arg-blame (and wrapped-blame (blame-swap wrapped-blame))) (define (missing-one init-ctc-pair) - (raise-blame-error - arg-blame - #:missing-party wrapped-neg-party - val - '(expected: "an init arg named ~a" given: "~a") - (car init-ctc-pair) - (case (length orig-named-args) - [(0) "no init args"] - [(1) - "an init arg named ~a" - (car (car orig-named-args))] - [(2) - "init args named~a" - (apply string-append (map (λ (x) (format " ~a" (car x))) orig-named-args))]))) + (raise-blame-error arg-blame + #:missing-party wrapped-neg-party + val + '(expected: "an init arg named ~a" given: "~a") + (car init-ctc-pair) + (case (length orig-named-args) + [(0) "no init args"] + [(1) + "an init arg named ~a" + (car (car orig-named-args))] + [(2) + "init args named~a" + (apply string-append + (map (λ (x) (format " ~a" (car x))) orig-named-args))]))) ;; this loop optimizes for the case where the init-ctc-pairs ;; and the named-args are in the same order, making extra ;; passes over the named-args when they aren't. @@ -4591,13 +4594,13 @@ An example (define-syntax (mixin stx) (syntax-case stx () [(_ (from ...) (to ...) clauses ...) - (let ([extract-renamed-names (λ (x) - (map (λ (x) - (localize (syntax-case x () - [(internal-name external-name) - (syntax external-name)] - [else x]))) - (syntax->list x)))]) + (let ([extract-renamed-names + (λ (x) + (map (λ (x) + (localize (syntax-case x () + [(internal-name external-name) (syntax external-name)] + [else x]))) + (syntax->list x)))]) (define (get-super-names stx) (syntax-case stx (inherit rename @@ -4669,7 +4672,8 @@ An example [(to-ids ...) (generate-temporaries (syntax (to ...)))] [(super-vars ...) (apply append (map get-super-names (syntax->list (syntax (clauses ...)))))] - [mixin-name (or (with-syntax ([tmp (syntax-local-name)]) (syntax (quote tmp))) + [mixin-name (or (with-syntax ([tmp (syntax-local-name)]) + (syntax (quote tmp))) (syntax (quote mixin)))]) ;; Build the class expression first, to give it a good src location: @@ -4684,24 +4688,24 @@ An example (check-mixin-super mixin-name super% (list from-ids ...)) class-expr))]) ;; Finally, build the complete mixin expression: - (class-syntax-protect - (syntax/loc stx - (let ([from-ids from] ...) - (let ([to-ids to] ...) - (check-mixin-from-interfaces (list from-ids ...)) - (check-mixin-to-interfaces (list to-ids ...)) - (check-interface-includes (list (quasiquote super-vars) ...) (list from-ids ...)) - mixin-expr))))))))])) + (class-syntax-protect (syntax/loc stx + (let ([from-ids from] ...) + (let ([to-ids to] ...) + (check-mixin-from-interfaces (list from-ids ...)) + (check-mixin-to-interfaces (list to-ids ...)) + (check-interface-includes (list (quasiquote super-vars) ...) + (list from-ids ...)) + mixin-expr))))))))])) (define externalizable<%> (_interface () externalize internalize)) (define writable<%> - (interface* - () - ([prop:custom-write - (lambda (obj port mode) (if mode (send obj custom-write port) (send obj custom-display port)))]) - custom-write - custom-display)) + (interface* () + ([prop:custom-write + (lambda (obj port mode) + (if mode (send obj custom-write port) (send obj custom-display port)))]) + custom-write + custom-display)) (define printable<%> (interface* () @@ -4711,20 +4715,20 @@ An example [(#t) (send obj custom-write port)] [(#f) (send obj custom-display port)] [else (send obj custom-print port mode)]))]) - custom-write - custom-display - custom-print)) + custom-write + custom-display + custom-print)) (define equal<%> - (interface* - () - ([prop:equal+hash - (list (lambda (obj obj2 base-equal?) (send obj equal-to? obj2 base-equal?)) - (lambda (obj base-hash-code) (send obj equal-hash-code-of base-hash-code)) - (lambda (obj base-hash2-code) (send obj equal-secondary-hash-code-of base-hash2-code)))]) - equal-to? - equal-hash-code-of - equal-secondary-hash-code-of)) + (interface* () + ([prop:equal+hash + (list (lambda (obj obj2 base-equal?) (send obj equal-to? obj2 base-equal?)) + (lambda (obj base-hash-code) (send obj equal-hash-code-of base-hash-code)) + (lambda (obj base-hash2-code) + (send obj equal-secondary-hash-code-of base-hash2-code)))]) + equal-to? + equal-hash-code-of + equal-secondary-hash-code-of)) ;; Providing normal functionality: (provide (protect-out get-field/proc) diff --git a/tests/large2.rkt.out b/tests/large2.rkt.out index c70fb89..faa1ffa 100644 --- a/tests/large2.rkt.out +++ b/tests/large2.rkt.out @@ -384,12 +384,12 @@ (inner (void) after-delete x y)) (apply super-make-object args))] - [get-program-editor-mixin (λ () - (drracket:tools:only-in-phase - 'drracket:unit:get-program-editor-mixin - 'phase2 - 'init-complete) - program-editor-mixin)] + [get-program-editor-mixin + (λ () + (drracket:tools:only-in-phase 'drracket:unit:get-program-editor-mixin + 'phase2 + 'init-complete) + program-editor-mixin)] [add-to-program-editor-mixin (λ (mixin) (drracket:tools:only-in-phase 'drracket:unit:add-to-program-editor-mixin 'phase1) @@ -1425,8 +1425,8 @@ (define/private (new-logger-text) (set! logger-gui-text - (new (text:hide-caret/selection-mixin - (editor:standard-style-list-mixin text:line-spacing%)))) + (new (text:hide-caret/selection-mixin (editor:standard-style-list-mixin + text:line-spacing%)))) (send logger-gui-text lock #t)) (define/public (update-logger-window command) @@ -1605,8 +1605,8 @@ ;; start-transcript : -> void ;; turns on the transcript and shows the transcript gui (define/private (start-transcript) - (let ([transcript-directory - (mred:get-directory (string-constant please-choose-a-log-directory) this)]) + (let ([transcript-directory (mred:get-directory (string-constant please-choose-a-log-directory) + this)]) (when (and transcript-directory (ensure-empty transcript-directory)) (send transcript-menu-item set-label (string-constant stop-logging)) (set! transcript transcript-directory) @@ -1642,13 +1642,13 @@ (let ([dir-list (directory-list transcript-directory)]) (or (null? dir-list) - (let ([query (message-box (string-constant drscheme) - (gui-utils:format-literal-label - (string-constant erase-log-directory-contents) - transcript-directory) - this - '(yes-no) - #:dialog-mixin frame:focus-table-mixin)]) + (let ([query (message-box + (string-constant drscheme) + (gui-utils:format-literal-label (string-constant erase-log-directory-contents) + transcript-directory) + this + '(yes-no) + #:dialog-mixin frame:focus-table-mixin)]) (cond [(equal? query 'no) #f] [(equal? query 'yes) @@ -1666,20 +1666,20 @@ #t)]))))) (define/override (make-root-area-container cls parent) - (let* ([_module-browser-parent-panel (super make-root-area-container - (make-two-way-prefs-dragable-panel% - panel:horizontal-dragable% - 'drracket:module-browser-size-percentage) - parent)] + (let* ([_module-browser-parent-panel + (super make-root-area-container + (make-two-way-prefs-dragable-panel% panel:horizontal-dragable% + 'drracket:module-browser-size-percentage) + parent)] [_module-browser-panel (new-vertical-panel% (parent _module-browser-parent-panel) (alignment '(left center)) (stretchable-width #f))] [planet-status-outer-panel (new vertical-pane% [parent _module-browser-parent-panel])] [execute-warning-outer-panel (new vertical-pane% [parent planet-status-outer-panel])] - [logger-outer-panel (new (make-two-way-prefs-dragable-panel% - panel:vertical-dragable% - 'drracket:logging-size-percentage) - [parent execute-warning-outer-panel])] + [logger-outer-panel + (new (make-two-way-prefs-dragable-panel% panel:vertical-dragable% + 'drracket:logging-size-percentage) + [parent execute-warning-outer-panel])] [trans-outer-panel (new vertical-pane% [parent logger-outer-panel])] [root (make-object cls trans-outer-panel)]) (set! module-browser-parent-panel _module-browser-parent-panel) @@ -2075,14 +2075,15 @@ (hash-ref! tab-label-cache fn (lambda () - (path->string - (or (shrink-path-wrt - nfn - (filter values - (for/list ([other-tab (in-list tabs)]) - (define fn (send (send other-tab get-defs) get-filename)) - (and fn (simple-form-path fn))))) - (let-values ([(base name dir?) (split-path nfn)]) name)))))) + (path->string (or (shrink-path-wrt nfn + (filter values + (for/list ([other-tab (in-list tabs)]) + (define fn + (send (send other-tab get-defs) + get-filename)) + (and fn (simple-form-path fn))))) + (let-values ([(base name dir?) (split-path nfn)]) + name)))))) (define/private (add-modified-flag text string) (if (send text is-modified?) @@ -2916,7 +2917,9 @@ (if (ormap (λ (x) (send x has-focus?)) interactions-canvases) 'ints 'defs))) (define/private (get-tab-visible-regions txt) - (map (λ (canvas) (let-values ([(x y w h _) (get-visible-region canvas)]) (list x y w h))) + (map (λ (canvas) + (let-values ([(x y w h _) (get-visible-region canvas)]) + (list x y w h))) (send txt get-canvases))) (inherit set-text-to-search @@ -3130,28 +3133,28 @@ (define (overview-shown?) (send (send (get-current-tab) get-defs) get-inline-overview-enabled?)) (define overview-menu-item - (new - menu:can-restore-menu-item% - (shortcut #\u) - (label - (if (overview-shown?) (string-constant hide-overview) (string-constant show-overview))) - (parent (get-show-menu)) - [demand-callback - (λ (mi) - (send mi - set-label - (if (overview-shown?) - (string-constant hide-overview) - (string-constant show-overview))))] - (callback - (λ (menu evt) - (cond - [(overview-shown?) - (preferences:set 'drracket:inline-overview-shown? #f) - (send (send (get-current-tab) get-defs) set-inline-overview-enabled? #f)] - [else - (preferences:set 'drracket:inline-overview-shown? #t) - (send (send (get-current-tab) get-defs) set-inline-overview-enabled? #t)]))))) + (new menu:can-restore-menu-item% + (shortcut #\u) + (label (if (overview-shown?) + (string-constant hide-overview) + (string-constant show-overview))) + (parent (get-show-menu)) + [demand-callback + (λ (mi) + (send mi + set-label + (if (overview-shown?) + (string-constant hide-overview) + (string-constant show-overview))))] + (callback + (λ (menu evt) + (cond + [(overview-shown?) + (preferences:set 'drracket:inline-overview-shown? #f) + (send (send (get-current-tab) get-defs) set-inline-overview-enabled? #f)] + [else + (preferences:set 'drracket:inline-overview-shown? #t) + (send (send (get-current-tab) get-defs) set-inline-overview-enabled? #t)]))))) (set-show-menu-sort-key overview-menu-item 301)) (set! module-browser-menu-item @@ -3364,9 +3367,9 @@ (send module-browser-panel begin-container-sequence) (unless module-browser-ec (set! module-browser-pb - (drracket:module-overview:make-module-overview-pasteboard - #t - (λ (x) (mouse-currently-over x)))) + (drracket:module-overview:make-module-overview-pasteboard #t + (λ (x) + (mouse-currently-over x)))) (set! module-browser-ec (make-object editor-canvas% module-browser-panel module-browser-pb)) (let* ([show-callback (λ (cb key) @@ -3394,11 +3397,11 @@ (string-constant module-browser-name-long) (string-constant module-browser-name-very-long))) (selection (preferences:get 'drracket:module-browser:name-length)) - (callback - (λ (x y) - (let ([selection (send module-browser-name-length-choice get-selection)]) - (preferences:set 'drracket:module-browser:name-length selection) - (update-module-browser-name-length selection)))))) + (callback (λ (x y) + (let ([selection (send module-browser-name-length-choice + get-selection)]) + (preferences:set 'drracket:module-browser:name-length selection) + (update-module-browser-name-length selection)))))) (update-module-browser-name-length (preferences:get 'drracket:module-browser:name-length)) (set! module-browser-button @@ -3452,9 +3455,9 @@ module-browser-pb (drracket:language:make-text/pos definitions-text 0 (send definitions-text last-position)) (λ (str) - (update-status-line - 'plt:module-browser - (gui-utils:trim-string (format module-browser-progress-constant str) 200))) + (update-status-line 'plt:module-browser + (gui-utils:trim-string (format module-browser-progress-constant str) + 200))) (λ (user-thread user-custodian) (send mod-tab set-breakables user-thread user-custodian))) (send mod-tab set-breakables old-break-thread old-custodian) (send mod-tab enable-evaluation) @@ -3520,8 +3523,9 @@ (get-module-path-from-user #:init (or editing-module-path (preferences:get 'drracket:open-module-path-last-used)) #:pref 'drracket:open-module-path-last-used - #:current-directory - (and editing-path (let-values ([(base name dir?) (split-path editing-path)]) base)))) + #:current-directory (and editing-path + (let-values ([(base name dir?) (split-path editing-path)]) + base)))) (when pth (handler:edit-file pth)))]) (super file-menu:between-open-and-revert file-menu) @@ -3532,8 +3536,8 @@ (set! close-tab-menu-item (new (get-menu-item%) (label (string-constant close-tab)) - (demand-callback - (λ (item) (send item enable (1 . < . (send tabs-panel get-number))))) + (demand-callback (λ (item) + (send item enable (1 . < . (send tabs-panel get-number))))) (parent file-menu) (callback (λ (x y) (close-current-tab)))))) (super file-menu:between-close-and-quit file-menu)) @@ -3868,10 +3872,10 @@ (define/public (get-special-menu) insert-menu) (define/public (choose-language-callback) - (let ([new-settings (drracket:language-configuration:language-dialog - #f - (send definitions-text get-next-settings) - this)]) + (let ([new-settings (drracket:language-configuration:language-dialog #f + (send definitions-text + get-next-settings) + this)]) (when new-settings (send definitions-text set-next-settings new-settings)))) @@ -3919,32 +3923,32 @@ [parent language-menu] [callback (λ (item evt) - (update-settings - ((teachpack-callbacks-remove tp-callbacks) settings name)))])) + (update-settings ((teachpack-callbacks-remove tp-callbacks) settings + name)))])) tp-names))))] [else - (set! - teachpack-items - (list - (new menu:can-restore-menu-item% - [label (string-constant add-teachpack-menu-item-label)] - [parent language-menu] - [callback - (λ (_1 _2) - (message-box - (string-constant drscheme) - (gui-utils:format-literal-label - (string-constant teachpacks-only-in-languages) - (apply string-append - (reverse - (filter - values - (map (λ (l) - (and (send l capability-value 'drscheme:teachpack-menu-items) - (format "\n ~a" (send l get-language-name)))) - (drracket:language-configuration:get-languages)))))) - this - #:dialog-mixin frame:focus-table-mixin))])))]))) + (set! teachpack-items + (list (new menu:can-restore-menu-item% + [label (string-constant add-teachpack-menu-item-label)] + [parent language-menu] + [callback + (λ (_1 _2) + (message-box + (string-constant drscheme) + (gui-utils:format-literal-label + (string-constant teachpacks-only-in-languages) + (apply string-append + (reverse + (filter + values + (map (λ (l) + (and (send l + capability-value + 'drscheme:teachpack-menu-items) + (format "\n ~a" (send l get-language-name)))) + (drracket:language-configuration:get-languages)))))) + this + #:dialog-mixin frame:focus-table-mixin))])))]))) (define/private (initialize-menus) (define mb (get-menu-bar)) @@ -4748,15 +4752,15 @@ (define msg2 (new message% [parent top-hp] [label (string-constant limit-memory-megabytes)])) (define bp (new-horizontal-panel% [parent d])) (define-values (ok-button cancel-button) - (gui-utils:ok/cancel-buttons - bp - (λ (a b) - (cond - [(send limited-rb get-selection) - (set! result (string->number (send (send tb get-editor) get-text)))] - [else (set! result #t)]) - (send d show #f)) - (λ (a b) (send d show #f)))) + (gui-utils:ok/cancel-buttons bp + (λ (a b) + (cond + [(send limited-rb get-selection) + (set! result + (string->number (send (send tb get-editor) get-text)))] + [else (set! result #t)]) + (send d show #f)) + (λ (a b) (send d show #f)))) (define result #f) @@ -5107,21 +5111,20 @@ (send (send frame get-interactions-text) initialize-console) frame))) -(define/contract - (compute-label-string fn) - (-> (or/c path? #f) label-string?) - (cond - [fn - (define base-title (format (string-constant module-browser-in-file) "")) - (define str (path->string fn)) - (define limit (- 200 (string-length base-title))) - (define str-to-use - (if (<= (string-length str) limit) - str - (string-append "..." - (substring str (+ (- (string-length str) limit) 3) (string-length str))))) - (format (string-constant module-browser-in-file) str-to-use)] - [else (string-constant module-browser-no-file)])) +(define/contract (compute-label-string fn) + (-> (or/c path? #f) label-string?) + (cond + [fn + (define base-title (format (string-constant module-browser-in-file) "")) + (define str (path->string fn)) + (define limit (- 200 (string-length base-title))) + (define str-to-use + (if (<= (string-length str) limit) + str + (string-append "..." + (substring str (+ (- (string-length str) limit) 3) (string-length str))))) + (format (string-constant module-browser-in-file) str-to-use)] + [else (string-constant module-browser-no-file)])) ;; is-lang-line? : string -> boolean ;; given the first line in the editor, this returns #t if it is a #lang line. diff --git a/tests/let-values.rkt b/tests/let-values.rkt new file mode 100644 index 0000000..3a8732a --- /dev/null +++ b/tests/let-values.rkt @@ -0,0 +1,16 @@ +(let-values ([(aaa) bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb] + [(aac) bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc]) + dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd) + + +(let-values ([(aaa) bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb] + [(aac) bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc]) + dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd) + +(let-values ([(aaa) bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb] + [(aac) bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc]) + dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd) + +(let-values ([(aaa) bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb] + [(aac) bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc]) + dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd) diff --git a/tests/let-values.rkt.out b/tests/let-values.rkt.out new file mode 100644 index 0000000..8566b33 --- /dev/null +++ b/tests/let-values.rkt.out @@ -0,0 +1,20 @@ +(let-values ([(aaa) bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb] + [(aac) bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc]) + dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd) + +(let-values ([(aaa) bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb] + [(aac) + bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc]) + dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd) + +(let-values + ([(aaa) bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb] + [(aac) bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc]) + dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd) + +(let-values + ([(aaa) + bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb] + [(aac) + bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbc]) + dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd) diff --git a/tokenize.rkt b/tokenize.rkt index 9fb1908..434d58a 100644 --- a/tokenize.rkt +++ b/tokenize.rkt @@ -1,3 +1,5 @@ +;; The tokenizer pass + #lang racket/base (provide tokenize