feat: use pretty-expressive

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)

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,30 +44,40 @@
             [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 (<s> 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))
                     [#f ((hook #f) d)]
                     [(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 ...]
          [_

for-profiling.rkt

@@ -1,3 +1,5 @@
+;; An entry suitable for raco profile
+
 #lang racket
 
 (module+ main

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"))

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"))
 

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?

raco.rkt

@@ -1,3 +1,5 @@
+;; An entry point of raco fmt
+
 #lang racket/base
 
 ; don't run this file for testing:
@@ -10,19 +12,33 @@
          (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
    (:current-width)
    (λ (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)

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)

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)