From 79a55604127cb541f2cb7b16f8c6314ac9002327 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Wed, 21 May 2025 21:52:47 -0400 Subject: [PATCH 01/29] `basilisp.pprint` namespace --- docs/differencesfromclojure.rst | 1 + src/basilisp/pprint.lpy | 385 +++++++++++++++++++++++++++++++- tests/basilisp/test_pprint.lpy | 58 ++++- 3 files changed, 442 insertions(+), 2 deletions(-) diff --git a/docs/differencesfromclojure.rst b/docs/differencesfromclojure.rst index 84be8599d..c55d5b670 100644 --- a/docs/differencesfromclojure.rst +++ b/docs/differencesfromclojure.rst @@ -225,6 +225,7 @@ Basilisp includes ports of some of the standard libraries from Clojure which sho * :lpy:ns:`basilisp.data` is a port of ``clojure.data`` * :lpy:ns:`basilisp.edn` is a port of ``clojure.edn`` * :lpy:ns:`basilisp.io` is a port of ``clojure.java.io`` +* :lpy:ns:`basilisp.pprint` is a port of ``clojure.pprint`` (excluding support for ``cl-format``) * :lpy:ns:`basilisp.set` is a port of ``clojure.set`` * :lpy:ns:`basilisp.shell` is a port of ``clojure.java.shell`` * :lpy:ns:`basilisp.stacktrace` is a port of ``clojure.stacktrace`` diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 22bd624f0..6d995ba61 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -1,5 +1,388 @@ (ns basilisp.pprint - (:require [basilisp.string :as str])) + (:require + [basilisp.string :as str] + [basilisp.walk :as walk]) + (:import fractions + io + os + threading)) + +(declare simple-dispatch code-dispatch write-out) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Dynamic Vars for Configuration ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def ^{:doc "The base used for printing integer literals and rationals. Default is 10." + :dynamic true} + *print-base* + 10) + +(def ^{:doc "The dispatch function used for pretty printing. + + Default is :lpy:fn:`simple-dispatch`." + :dynamic true} + *print-pprint-dispatch* + nil) + +(def ^{:doc "If bound to ``true``, calls to :lpy:fn:`write` will use pretty printing. + Default is ``false``, but :lpy:fn:`pprint` binds the value to ``true``." + :dynamic true} + *print-pretty* + false) + +(def ^{:doc "The soft upper limit for the length of the right margin. Default is 72." + :dynamic true} + *print-right-margin* + 72) + +(def ^{:doc "If ``true``, suppress printing symbol namespaces. This may be useful when + printing macroexpansions. + + Default is ``nil``." + :dynamic true} + *print-suppress-namespaces* + nil) + +;;;;;;;;;;;;;;;;;;; +;; Private State ;; +;;;;;;;;;;;;;;;;;;; + +(def ^:dynamic *current-level* 0) +(def ^:dynamic *current-length* nil) + +;;;;;;;;;;;;;;;;;;; +;; Column Writer ;; +;;;;;;;;;;;;;;;;;;; + +(def ^:dynamic ^:private *default-page-width* 72) + +(defn ^:private get-column-writer + "Return an :external:py:class:`io.TextIOBase` instance which keeps track of the + current line and column it has printed. + + The ``max-columns`` input defaults to :lpy:var:`*default-page-width*`. This value + is not used by the column writer, but may be introspected by callers. + + The current state can be fetched using :lpy:fn:`basilisp.core/deref`." + ([writer] + (get-column-writer writer *default-page-width*)) + ([writer max-columns] + (let [lock (threading/RLock) + state (volatile! {:max max-columns :col 0 :line 0 :base writer})] + (^:mutable reify + basilisp.lang.interfaces/IDeref + (deref [self] + (with [_ lock] + @state)) + + ^:abstract + ^{:abstract-members #{:flush :write}} + io/TextIOBase + (write [self s] + (with [_ lock] + (let [[init final] (.rsplit s os/linesep 1)] + (vswap! state + (fn [{:keys [col line] :as old-state}] + (if final + (let [nlines (count (.splitlines init))] + (-> old-state + (assoc :col (count final)) + (assoc :line (+ line nlines)))) + (assoc old-state :col (count init)))))) + (.write writer s))) + + (flush [self] + (with [_ lock] + (.flush writer))) + + (__repr__ [self] + (str "")))))) + +;;;;;;;;;;; +;; Types ;; +;;;;;;;;;;; + +(defrecord LogicalBlock [parent prefix suffix indent]) + +(deftype StartBlock [block start end]) + +(deftype EndBlock [block start end]) + +(deftype Blob [data trailing-white-space start end]) + +(deftype Indent [block relative-to offset start end]) + +(deftype Newline [block kind start end]) + +;;;;;;;;;;;;;;;;;;; +;; Pretty Writer ;; +;;;;;;;;;;;;;;;;;;; + +(defn ^:private buffer-length + "Return the length of a given `PrettyWriter` buffer in characters." + [buffer] + (if-let [buf (seq buffer)] + (- (.-end (last buf)) (.-start (first buf))) + 0)) + +(defprotocol PrettyWriter + (start-block [this prefix suffix]) + (end-block [this]) + (pp-newline [this kind])) + +(defn get-pretty-writer + "Return a pretty writer instance, which is also an :external:py:class:`io.TextIOBase`. + + The current state can be fetched using :lpy:fn:`basilisp.core/deref`." + [writer] + (let [lock (threading/RLock) + writer (get-column-writer writer) + state (volatile! {:base writer + :block (->LogicalBlock nil nil nil 0) + :buffer (queue) + :pos 0 + :trailing-white-space nil})] + (letfn [;; Private helpers can only be called while the lock is held + (tokens-fit? [state tokens] + (let [{:keys [base]} state + {:keys [col max]} @base] + (or (nil? max) + (pos? (- max (+ col (buffer-length tokens))))))) + + (write-line [state] + (let [{:keys [buffer]} state] + (assoc state :buffer + (loop [{:keys [buffer]} state] + nil)))) + + (add-to-buffer [state token] + (let [{:keys [buffer] :as state} (update state :buffer conj token)] + (if (not (tokens-fit? state buffer)) + (write-line state) + state)))] + (^:mutable reify + basilisp.lang.interfaces/IDeref + (deref [self] + (with [_ lock] + @state)) + + ^:abstract + ^{:abstract-members #{:flush :write}} + io/TextIOBase + (write [self s] + (with [_ lock] + (if-not (seq (:buffer @state)) + (.write writer s) + (do + (vswap! state (fn [{:keys [pos] :as old-state}] + (let [new-pos (+ pos (count s)) + blob (Blob s nil pos new-pos)] + (-> old-state + (assoc :pos new-pos) + (add-to-buffer blob))))))))) + + (flush [self] + (with [_ lock] + (.flush writer))) + + PrettyWriter + (start-block [self prefix suffix] + (with [_ lock] + (vswap! state (fn [{:keys [block base pos] :as old-state}] + (let [indent (:col @base) + new-block (LogicalBlock block + prefix + suffix + indent) + new-pos (if prefix + (+ pos (count prefix)) + pos) + start-block (StartBlock new-block pos new-pos)] + (-> old-state + (assoc :block new-block) + (add-to-buffer start-block) + (assoc :pos new-pos))))))) + (end-block [self] + (with [_ lock] + (vswap! state (fn [{:keys [block pos] :as old-state}] + (let [suffix (:suffix block) + new-pos (if suffix + (+ pos (count suffix)) + pos) + end-block (EndBlock block pos new-pos)] + (-> old-state + (assoc :block (:parent block)) + (add-to-buffer end-block))))))) + (pp-newline [self kind] + (with [_ lock] + (vswap! state (fn [{:keys [buffer block pos] :as old-state}] + (->> (Newline block kind pos pos) + (add-to-buffer old-state)))))))))) + +;;;;;;;;;;;;; +;; Helpers ;; +;;;;;;;;;;;;; + +(defmacro pprint-logical-block + [& body] + (let [flag-names #{:prefix :per-line-prefix :suffix} + [flags body] (loop [flags {} + body body] + (if (flag-names (first body)) + (recur (assoc flags (first body) (second body)) + (nthrest body 2)) + [flags body]))] + `(with-bindings {#'*current-level* (inc *current-level*)} + ~(let [{:keys [prefix suffix]} flags] + `(start-block *out* ~prefix ~suffix)) + ~@body + (end-block *out*)))) + +(defmacro print-length-loop + ":lpy:fn:`loop` -like macro which loops at most :lpy:fn:`basilisp.core/*print-length*` + times, which is often useful when defining custom pretty-printing functions." + [bindings & body] + (let [len-sym (gensym "len") + body (walk/postwalk + (fn [form] + (if (and (list? form) (= (first form) 'recur)) + (apply list 'recur `(inc ~len-sym) (rest form)) + form)) + body)] + `(loop [~len-sym 0 + ~@bindings] + (if (or (not *print-length*) (< ~len-sym *print-length*)) + (do ~@body) + (.write *out* "..."))))) + +(defn pprint-newline + "" + [kind] + (when-not (#{:linear :mandatory :miser :fill} kind) + (throw + (ex-info "Newline must be one of: :linear, :mandatory, :miser, :fill" + {:kind kind}))) + (pp-newline *out* kind)) + +;;;;;;;;;;;;;;;;;;;;; +;; Simple Dispatch ;; +;;;;;;;;;;;;;;;;;;;;; + +(defmulti simple-dispatch type) + +(defmethod simple-dispatch :default + [obj] + (pr obj)) + +(defmethod simple-dispatch python/int + [obj] + (if-let [base (case *print-base* + 2 "{0:b}" + 8 "{0:o}" + 10 "{}" + 16 "{0:x}" + nil)] + (print (.format base obj)) + (throw + (ex-info "Invalid integral base" {:base *print-base*})))) + +;; This `python/bool` override is required because Python `bool` types are also +;; instances of `python/int`, so they will be caught by the `int` dispatch otherwise. +(defmethod simple-dispatch python/bool + [obj] + (pr obj)) + +(defmethod simple-dispatch fractions/Fraction + [obj] + (*print-pprint-dispatch* (numerator obj)) + (print "/") + (*print-pprint-dispatch* (denominator obj))) + +(defmethod simple-dispatch basilisp.lang.symbol/Symbol + [obj] + (if *print-suppress-namespaces* + (print (name obj)) + (pr obj))) + +(defn ^:private print-simple-coll + "Print a non-associative collection with the given prefix and suffix strings." + [prefix suffix coll] + (pprint-logical-block :prefix prefix :suffix suffix + (print-length-loop [v coll] + (when (seq v) + (write-out (first v)) + (when-let [more (seq (rest v))] + (.write *out* " ") + (recur more)))))) + +(defmethod simple-dispatch basilisp.lang.interfaces/ISeq + [obj] + (print-simple-coll "(" ")" obj)) + +(defmethod simple-dispatch basilisp.lang.interfaces/IPersistentList + [obj] + (print-simple-coll "(" ")" obj)) + +(defmethod simple-dispatch basilisp.lang.interfaces/IPersistentSet + [obj] + (print-simple-coll "#{" "}" obj)) + +(defmethod simple-dispatch basilisp.lang.interfaces/IPersistentVector + [obj] + (print-simple-coll "[" "]" obj)) + +(defmethod simple-dispatch basilisp.lang.interfaces/IPersistentMap + [obj] + (pprint-logical-block :prefix "{" :suffix "}" + (print-length-loop [pair obj] + (when-let [[k v] (seq pair)] + (write-out k) + (.write *out* " ") + (write-out v) + (when-let [more (seq (rest v))] + (.write *out* " ") + (recur more)))))) + +(alter-var-root #'*print-pprint-dispatch* (constantly simple-dispatch)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Pretty Printing Public API ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn write-out + [object] + (let [length-reached? (and *current-length* + *print-length* + (>= *current-length* *print-length*))] + (if *print-pretty* + (if length-reached? + (print "...") + (do + (when-let [l *current-length*] + (set! *current-length* (inc l))) + (*print-pprint-dispatch* object))) + (pr object)))) + +(defn pprint + "Pretty print ``object`` to the given ``writer``. + + If no ``writer`` is given, the value bound to :lpy:var:`basilisp.core/*out*` is + used." + ([object] + (pprint object *out*)) + ([object writer] + (binding [*out* (get-pretty-writer writer) + *print-pretty* true] + (write-out object) + (newline)))) + +(defn pp + "Print the last thing output to the REPL. + + Equivalent to calling ``(pprint *1)``." + [] + (pprint *1)) (defn print-table "Print a collection of maps as a table to the buffer currently bound to diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index 7f412d726..fad7331ca 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -3,7 +3,63 @@ [basilisp.pprint :as pprint] [basilisp.string :as str] [basilisp.test :refer [deftest are is testing]]) - (:import os textwrap)) + (:import io + os + textwrap)) + +(deftest column-writer-test + (let [write (fn [s] + (with [buf (io/StringIO)] + (let [writer (@#'pprint/get-column-writer buf)] + (.write writer s) + (select-keys @writer [:col :line]))) )] + (is (= {:line 0 :col 5} (write "hello"))) + (is (= {:line 1 :col 15} (write "hello\nthere my friend"))) + (is (= {:line 2 :col 0} (write "hello\nthere my friend\n"))) + (is (= {:line 0 :col 0} (write ""))))) + +(deftest pprint-test + (testing "scalars" + (are [res expr] (= res (str/rtrim (with-out-str (pprint/pprint expr)))) + "nil" nil + "true" true + "false" false + "0" 0 + "-1.0" -1.0 + "0.0" 0.0 + "1.0" 1.0 + "1" 1 + "-1" -1 + "22/7" 22/7 + "\"\"" "" + "\"a string\"" "a string" + ":kw" :kw + ":ns/kw" :ns/kw + ":long.ns/kw" :long.ns/kw + "sym" 'sym + "ns/sym" 'ns/sym + "long.ns/sym" 'long.ns/sym))) + +(deftest pprint-suppress-namespaces-test + (testing "no supression" + (are [res expr] (= res (str/rtrim (with-out-str (pprint/pprint expr)))) + ":kw" :kw + ":ns/kw" :ns/kw + ":long.ns/kw" :long.ns/kw + "sym" 'sym + "ns/sym" 'ns/sym + "long.ns/sym" 'long.ns/sym)) + + (testing "with suppression" + (are [res expr] (= res (binding [pprint/*print-suppress-namespaces* true] + (str/rtrim + (with-out-str (pprint/pprint expr))))) + ":kw" :kw + ":ns/kw" :ns/kw + ":long.ns/kw" :long.ns/kw + "sym" 'sym + "sym" 'ns/sym + "sym" 'long.ns/sym))) (defn trim-newlines-and-dedent [s] From 9329ef6e670ebf61bbb7a3e85527c727b72d337a Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Wed, 21 May 2025 21:59:25 -0400 Subject: [PATCH 02/29] Newline --- src/basilisp/pprint.lpy | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 6d995ba61..59ef96e4c 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -257,7 +257,13 @@ (.write *out* "..."))))) (defn pprint-newline - "" + "Emit a newline to the output buffer. + + ``:kind`` must be one of the following: + - ``:linear`` + - ``:mandatory`` + - ``:miser`` + - ``:fill``" [kind] (when-not (#{:linear :mandatory :miser :fill} kind) (throw @@ -314,6 +320,7 @@ (write-out (first v)) (when-let [more (seq (rest v))] (.write *out* " ") + (pprint-newline :linear) (recur more)))))) (defmethod simple-dispatch basilisp.lang.interfaces/ISeq @@ -340,6 +347,7 @@ (write-out k) (.write *out* " ") (write-out v) + (pprint-newline :linear) (when-let [more (seq (rest v))] (.write *out* " ") (recur more)))))) From c3a5c1d022b5dc03efe32d14511993fc35980767 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Sat, 24 May 2025 17:09:33 -0400 Subject: [PATCH 03/29] Not working but kinda working --- src/basilisp/pprint.lpy | 321 +++++++++++++++++++++++++++++++--------- 1 file changed, 252 insertions(+), 69 deletions(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 59ef96e4c..b3437b62b 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -1,4 +1,9 @@ (ns basilisp.pprint + "Basilisp pretty printing functionality. + + References: + - Oppen, Derek; \"Prettyprinting\"; October 1980 + - Waters, Richard; \"XP: A Common Lisp Pretty Printing System\"; March 1989" (:require [basilisp.string :as str] [basilisp.walk :as walk]) @@ -103,7 +108,7 @@ ;; Types ;; ;;;;;;;;;;; -(defrecord LogicalBlock [parent prefix suffix indent]) +(deftype LogicalBlock [parent prefix suffix ^:mutable indent ^:mutable force-nl?]) (deftype StartBlock [block start end]) @@ -115,17 +120,89 @@ (deftype Newline [block kind start end]) +(defn debug-token + [token] + (condp instance? token + StartBlock [":start" (python/id (.-block token))] + EndBlock [":end" (python/id (.-block token))] + Blob (.-data token) + Newline [(.-kind token) (python/id (.-block token))])) + ;;;;;;;;;;;;;;;;;;; ;; Pretty Writer ;; ;;;;;;;;;;;;;;;;;;; (defn ^:private buffer-length - "Return the length of a given `PrettyWriter` buffer in characters." + "Return the length of a given ``PrettyWriter`` buffer in characters." [buffer] (if-let [buf (seq buffer)] (- (.-end (last buf)) (.-start (first buf))) 0)) +(defn ^:private ancestor? + "Return true if ``parent`` is an ancestor logical block of ``child``." + [parent child] + (loop [child (.-parent child)] + (cond + (nil? child) false + (identical? parent child) true + :else (recur (.-parent child))))) + +(defn ^:private split-queue-with + "Split a queue ``buffer`` until ``(pred elem)`` returns ``true``\\. + + Return a two element vector with the first element being the elements coming + before ``(pred elem)`` returned true, and the second element as a queue of all + remaining elements." + [pred buffer] + (loop [before (queue) + after buffer] + (if (seq after) + (let [e (first after)] + (if (not (pred e)) + (recur (conj before e) + (pop after)) + [before after])) + [before after]))) + +(def ^:private split-at-newline + "Split a queue at the first instance of a ``Newline`` token." + (partial split-queue-with #(instance? Newline %))) + +(defmacro pdebug + [& args] + `(do + (.write *err* (str ~@args)) + (.write *err* \newline))) + +(defn ^:private get-section + "Get the section after a conditional newline, as defined by Waters: + + The section after a conditional newline consists of: all the output up to, + but not including, (a) the next conditional newline imediately contained in + the same logical block; or if (a) is not applicable, (b) the next newline + that is at a lesser level of nesting in logical blocks; or if (b) is not + applicable, (c) the end of the output as a whole. + + -- Waters, \"XP: A Common Lisp Pretty Printing System\", March 1989" + [buffer] + (let [nl (first buffer) + block (.-block nl) + _ (pdebug "nl-block=" (python/id (.-block nl)) " " (.-block nl)) + comparator (fn [token] + (if (instance? Newline token) + (let [is-ancestor? (or #_(identical? (.-block token) block) + (ancestor? (.-block token) block))] + (pdebug "token=" (debug-token token) + " maybe-parent=" (python/id (.-block token)) + " is-ancestor?=" is-ancestor?) + is-ancestor?) + false))] + #_#(and (instance? Newline %) + (ancestor? (.-block %) block)) + (split-queue-with comparator + (pop buffer)))) + (defprotocol PrettyWriter (start-block [this prefix suffix]) (end-block [this]) @@ -138,87 +215,192 @@ [writer] (let [lock (threading/RLock) writer (get-column-writer writer) - state (volatile! {:base writer - :block (->LogicalBlock nil nil nil 0) + state (volatile! {:block (LogicalBlock nil nil nil 0 false) :buffer (queue) :pos 0 :trailing-white-space nil})] (letfn [;; Private helpers can only be called while the lock is held - (tokens-fit? [state tokens] - (let [{:keys [base]} state - {:keys [col max]} @base] + + ;; Return `true` if the given tokens will fit on the current line given + ;; the max column width set for the base writer (if one is set). + (tokens-fit? [tokens] + (let [{:keys [col max]} @writer] (or (nil? max) (pos? (- max (+ col (buffer-length tokens))))))) - (write-line [state] - (let [{:keys [buffer]} state] - (assoc state :buffer - (loop [{:keys [buffer]} state] - nil)))) - - (add-to-buffer [state token] - (let [{:keys [buffer] :as state} (update state :buffer conj token)] - (if (not (tokens-fit? state buffer)) - (write-line state) - state)))] + ;; Set `force-nl?` on the current logical block to ensure that any + ;; remaining `:linear` newlines associated with the block are emitted. + (set-block-force-nl! [block] + (loop [block block] + (when block + (when-not (.-force-nl? block) + (set! (.-force-nl? block) true) + (pdebug "force newline " block)) + (recur (.-parent block))))) + + ;; Set the `indent` of the current logical block to match the current + ;; column position of the base writer. + (set-block-indent! [block prefix] + (let [indent (+ (:col @writer) (count prefix))] + #_(.write *err* (str "indent: " indent " block: " block)) + #_(.write *err* \newline) + (set! (.-indent block) indent))) + + ;; Return `true` if the given newline type should be emitted. + (emit-nl? [token] + #_(.write *err* (str token)) + #_(.write *err* \newline) + (condp = (.-kind token) + :mandatory true + :fill nil + :linear (let [[section _] (get-section (:buffer @state)) + section-fits? (not (tokens-fit? section)) + should-emit-newline? (or (.-force-nl? (.-block token)) + (let [[section _] (get-section (:buffer @state))] + (not (tokens-fit? section))))] + (pdebug "should-emit-newline?=" should-emit-newline? + " buffer-length=" (buffer-length section) + " writer=" @writer + " not-section-fits?=" section-fits? + " section=" (map debug-token section) + " token=" token) + should-emit-newline?) + :miser nil)) + + ;; Emit the newline token to the base writer unconditionally. + ;; TODO: this is wrong + (emit-nl [token] + (pdebug "emitting nl=" token) + (set-block-force-nl! (.-block token)) + (let [indent (or (.-indent (.-block token)) 0)] + (str os/linesep (.ljust "" indent)))) + + ;; Write a sequence of tokens to the base writer. + (write-tokens [tokens] + (doseq [token tokens] + #_(.write *err* (str token)) + #_(.write *err* \newline) + (when-let [s (condp instance? token + Blob (.-data token) + Newline (do + #_(.write *err* (str token)) + #_(.write *err* \newline) + (when (or (= (.-kind token) :mandatory) + (.-force-nl? (.-block token))) #_(emit-nl? token) + (emit-nl token))) + StartBlock (let [block (.-block token)] + (when-let [prefix (.-prefix block)] + (set-block-indent! block prefix) + prefix)) + EndBlock (.-suffix (.-block token)))] + (.write writer s)))) + + ;; Write a single line and possibly emit a trailing conditional newline. + (write-line [] + (let [{:keys [buffer]} @state + [s buf] (split-at-newline buffer)] + #_(pdebug {:buffer (map debug-token buf) :s (map debug-token s)}) + (when (seq s) + (write-tokens s)) + (vswap! state #(assoc % :buffer buf)) + ;; check if buffer still exceeds length; if so, we'll need to emit newlines + (when buf + (let [[section remainder] (get-section buf) + _ (pdebug {:section (map debug-token section) + :remainder (map debug-token remainder)}) + maybe-nl (first buf) + buf (if (emit-nl? maybe-nl) + (do + (.write writer (emit-nl maybe-nl)) + (next buf)) + buf)] + (if-not (tokens-fit? buf) + (do + (pdebug "writing section " (map debug-token section)) + (write-tokens section) + (vswap! state #(assoc % :buffer remainder))) + (vswap! state #(assoc % :bufer buf))))))) + + ;; Write tokens from the buffer to the base writer as long as the tokens + ;; in the buffer won't fit on the current line. + (write-lines [] + (loop [{:keys [buffer]} @state] + (if-not (tokens-fit? buffer) + (write-line) + (recur @state)))) + + ;; Add a token to the buffer and flush the buffer to the base writer if + ;; the tokens do not fit on the base line. + (add-to-buffer [token] + (let [{:keys [buffer]} (vswap! state #(update % :buffer conj token))] + (when-not (tokens-fit? buffer) + (write-lines)))) + + ;; Update the current position in the state based on the given value, + ;; returning a vector of the starting position and ending position. + ;; + ;; If the value is a string, the position will be incremented by the + ;; length of the string. Otherwise, the position will be unchanged. + (update-pos [v] + (let [start-pos (:pos @state)] + (when (string? v) + (vswap! state #(update % :pos + (count v)))) + [start-pos (:pos @state)]))] + (^:mutable reify basilisp.lang.interfaces/IDeref (deref [self] - (with [_ lock] - @state)) + (with [_ lock] + @state)) ^:abstract ^{:abstract-members #{:flush :write}} io/TextIOBase (write [self s] - (with [_ lock] - (if-not (seq (:buffer @state)) - (.write writer s) - (do - (vswap! state (fn [{:keys [pos] :as old-state}] - (let [new-pos (+ pos (count s)) - blob (Blob s nil pos new-pos)] - (-> old-state - (assoc :pos new-pos) - (add-to-buffer blob))))))))) + (with [_ lock] + (if-not (seq (:buffer @state)) + (.write writer s) + (do + (let [[old-pos new-pos] (update-pos s) + blob (Blob s nil old-pos new-pos)] + (add-to-buffer blob)))) + (count s))) (flush [self] - (with [_ lock] - (.flush writer))) + (with [_ lock] + (when-let [buf (:buffer @state)] + (write-tokens buf)) + (.flush writer))) PrettyWriter (start-block [self prefix suffix] - (with [_ lock] - (vswap! state (fn [{:keys [block base pos] :as old-state}] - (let [indent (:col @base) - new-block (LogicalBlock block - prefix - suffix - indent) - new-pos (if prefix - (+ pos (count prefix)) - pos) - start-block (StartBlock new-block pos new-pos)] - (-> old-state - (assoc :block new-block) - (add-to-buffer start-block) - (assoc :pos new-pos))))))) + (with [_ lock] + (let [current-block (:block @state) + new-block (LogicalBlock current-block prefix suffix 0 false) + [old-pos new-pos] (update-pos prefix) + start-block (StartBlock new-block old-pos new-pos)] + (vswap! state #(-> % + (assoc :block new-block) + (assoc :pos new-pos))) + (add-to-buffer start-block))) + nil) + (end-block [self] - (with [_ lock] - (vswap! state (fn [{:keys [block pos] :as old-state}] - (let [suffix (:suffix block) - new-pos (if suffix - (+ pos (count suffix)) - pos) - end-block (EndBlock block pos new-pos)] - (-> old-state - (assoc :block (:parent block)) - (add-to-buffer end-block))))))) + (with [_ lock] + (let [{:keys [block pos]} @state + suffix (.-suffix block) + [old-pos new-pos] (update-pos suffix) + end-block (EndBlock block pos new-pos)] + (vswap! state #(assoc % :block (.-parent block))) + (add-to-buffer end-block))) + nil) + (pp-newline [self kind] - (with [_ lock] - (vswap! state (fn [{:keys [buffer block pos] :as old-state}] - (->> (Newline block kind pos pos) - (add-to-buffer old-state)))))))))) + (with [_ lock] + (let [{:keys [block pos]} @state + nl (Newline block kind pos pos)] + (add-to-buffer nl))) + nil))))) ;;;;;;;;;;;;; ;; Helpers ;; @@ -342,15 +524,16 @@ (defmethod simple-dispatch basilisp.lang.interfaces/IPersistentMap [obj] (pprint-logical-block :prefix "{" :suffix "}" - (print-length-loop [pair obj] - (when-let [[k v] (seq pair)] - (write-out k) - (.write *out* " ") - (write-out v) - (pprint-newline :linear) - (when-let [more (seq (rest v))] + (print-length-loop [m obj] + (when (seq m) + (let [[k v] (first m)] + (write-out k) (.write *out* " ") - (recur more)))))) + (write-out v) + (pprint-newline :linear) + (when-let [more (seq (rest m))] + (.write *out* " ") + (recur more))))))) (alter-var-root #'*print-pprint-dispatch* (constantly simple-dispatch)) From 6b6d90ff23c63e7aa84892b2f619a348c7683ae5 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Mon, 2 Jun 2025 18:41:59 -0400 Subject: [PATCH 04/29] Got it working, kinda --- src/basilisp/pprint.lpy | 479 ++++++++++++++++++--------------- tests/basilisp/test_pprint.lpy | 125 ++++++++- 2 files changed, 380 insertions(+), 224 deletions(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index b3437b62b..2917eff96 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -2,6 +2,7 @@ "Basilisp pretty printing functionality. References: + - Tom Faulhaber; `clojure.pprint` - Oppen, Derek; \"Prettyprinting\"; October 1980 - Waters, Richard; \"XP: A Common Lisp Pretty Printing System\"; March 1989" (:require @@ -12,6 +13,11 @@ os threading)) +;; TODO: +;; - miser and fill newlines +;; - indent controls +;; - arbitrary base printing for integers + (declare simple-dispatch code-dispatch write-out) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -60,6 +66,12 @@ ;; Column Writer ;; ;;;;;;;;;;;;;;;;;;; +(defmacro pdebug + [& args] + `(do + (.write *err* (str ~@args)) + (.write *err* \newline))) + (def ^:dynamic ^:private *default-page-width* 72) (defn ^:private get-column-writer @@ -94,7 +106,7 @@ (-> old-state (assoc :col (count final)) (assoc :line (+ line nlines)))) - (assoc old-state :col (count init)))))) + (update old-state :col + (count init)))))) (.write writer s))) (flush [self] @@ -108,13 +120,15 @@ ;; Types ;; ;;;;;;;;;;; -(deftype LogicalBlock [parent prefix suffix ^:mutable indent ^:mutable force-nl?]) +(deftype LogicalBlock [parent prefix per-line-prefix suffix ^:mutable indent ^:mutable force-nl?] + (__repr__ [self] + (str [(python/id self) (python/repr parent) prefix suffix indent force-nl?]))) (deftype StartBlock [block start end]) (deftype EndBlock [block start end]) -(deftype Blob [data trailing-white-space start end]) +(deftype Blob [data start end]) (deftype Indent [block relative-to offset start end]) @@ -169,12 +183,6 @@ "Split a queue at the first instance of a ``Newline`` token." (partial split-queue-with #(instance? Newline %))) -(defmacro pdebug - [& args] - `(do - (.write *err* (str ~@args)) - (.write *err* \newline))) - (defn ^:private get-section "Get the section after a conditional newline, as defined by Waters: @@ -188,23 +196,19 @@ [buffer] (let [nl (first buffer) block (.-block nl) - _ (pdebug "nl-block=" (python/id (.-block nl)) " " (.-block nl)) + ;;_ (pdebug "nl-block=" (python/id (.-block nl)) " " (.-block nl)) comparator (fn [token] (if (instance? Newline token) - (let [is-ancestor? (or #_(identical? (.-block token) block) - (ancestor? (.-block token) block))] - (pdebug "token=" (debug-token token) - " maybe-parent=" (python/id (.-block token)) + (let [is-ancestor? (ancestor? (.-block token) block)] + #_(pdebug "token=" [(.-kind token) (.-block token)] + " block=" block " is-ancestor?=" is-ancestor?) is-ancestor?) false))] - #_#(and (instance? Newline %) - (ancestor? (.-block %) block)) - (split-queue-with comparator - (pop buffer)))) + (split-queue-with comparator (pop buffer)))) (defprotocol PrettyWriter - (start-block [this prefix suffix]) + (start-block [this prefix per-line-prefix suffix]) (end-block [this]) (pp-newline [this kind])) @@ -212,201 +216,185 @@ "Return a pretty writer instance, which is also an :external:py:class:`io.TextIOBase`. The current state can be fetched using :lpy:fn:`basilisp.core/deref`." - [writer] - (let [lock (threading/RLock) - writer (get-column-writer writer) - state (volatile! {:block (LogicalBlock nil nil nil 0 false) - :buffer (queue) - :pos 0 - :trailing-white-space nil})] - (letfn [;; Private helpers can only be called while the lock is held - - ;; Return `true` if the given tokens will fit on the current line given - ;; the max column width set for the base writer (if one is set). - (tokens-fit? [tokens] - (let [{:keys [col max]} @writer] - (or (nil? max) - (pos? (- max (+ col (buffer-length tokens))))))) - - ;; Set `force-nl?` on the current logical block to ensure that any - ;; remaining `:linear` newlines associated with the block are emitted. - (set-block-force-nl! [block] - (loop [block block] - (when block - (when-not (.-force-nl? block) - (set! (.-force-nl? block) true) - (pdebug "force newline " block)) - (recur (.-parent block))))) - - ;; Set the `indent` of the current logical block to match the current - ;; column position of the base writer. - (set-block-indent! [block prefix] - (let [indent (+ (:col @writer) (count prefix))] - #_(.write *err* (str "indent: " indent " block: " block)) - #_(.write *err* \newline) - (set! (.-indent block) indent))) - - ;; Return `true` if the given newline type should be emitted. - (emit-nl? [token] - #_(.write *err* (str token)) - #_(.write *err* \newline) - (condp = (.-kind token) - :mandatory true - :fill nil - :linear (let [[section _] (get-section (:buffer @state)) - section-fits? (not (tokens-fit? section)) - should-emit-newline? (or (.-force-nl? (.-block token)) - (let [[section _] (get-section (:buffer @state))] - (not (tokens-fit? section))))] - (pdebug "should-emit-newline?=" should-emit-newline? - " buffer-length=" (buffer-length section) - " writer=" @writer - " not-section-fits?=" section-fits? - " section=" (map debug-token section) - " token=" token) - should-emit-newline?) - :miser nil)) - - ;; Emit the newline token to the base writer unconditionally. - ;; TODO: this is wrong - (emit-nl [token] - (pdebug "emitting nl=" token) - (set-block-force-nl! (.-block token)) - (let [indent (or (.-indent (.-block token)) 0)] - (str os/linesep (.ljust "" indent)))) - - ;; Write a sequence of tokens to the base writer. - (write-tokens [tokens] - (doseq [token tokens] - #_(.write *err* (str token)) - #_(.write *err* \newline) - (when-let [s (condp instance? token - Blob (.-data token) - Newline (do - #_(.write *err* (str token)) - #_(.write *err* \newline) - (when (or (= (.-kind token) :mandatory) - (.-force-nl? (.-block token))) #_(emit-nl? token) - (emit-nl token))) - StartBlock (let [block (.-block token)] - (when-let [prefix (.-prefix block)] - (set-block-indent! block prefix) - prefix)) - EndBlock (.-suffix (.-block token)))] - (.write writer s)))) - - ;; Write a single line and possibly emit a trailing conditional newline. - (write-line [] - (let [{:keys [buffer]} @state - [s buf] (split-at-newline buffer)] - #_(pdebug {:buffer (map debug-token buf) :s (map debug-token s)}) - (when (seq s) - (write-tokens s)) - (vswap! state #(assoc % :buffer buf)) - ;; check if buffer still exceeds length; if so, we'll need to emit newlines - (when buf - (let [[section remainder] (get-section buf) - _ (pdebug {:section (map debug-token section) - :remainder (map debug-token remainder)}) - maybe-nl (first buf) - buf (if (emit-nl? maybe-nl) - (do - (.write writer (emit-nl maybe-nl)) - (next buf)) - buf)] - (if-not (tokens-fit? buf) - (do - (pdebug "writing section " (map debug-token section)) - (write-tokens section) - (vswap! state #(assoc % :buffer remainder))) - (vswap! state #(assoc % :bufer buf))))))) - - ;; Write tokens from the buffer to the base writer as long as the tokens - ;; in the buffer won't fit on the current line. - (write-lines [] - (loop [{:keys [buffer]} @state] - (if-not (tokens-fit? buffer) - (write-line) - (recur @state)))) - - ;; Add a token to the buffer and flush the buffer to the base writer if - ;; the tokens do not fit on the base line. - (add-to-buffer [token] - (let [{:keys [buffer]} (vswap! state #(update % :buffer conj token))] - (when-not (tokens-fit? buffer) - (write-lines)))) - - ;; Update the current position in the state based on the given value, - ;; returning a vector of the starting position and ending position. - ;; - ;; If the value is a string, the position will be incremented by the - ;; length of the string. Otherwise, the position will be unchanged. - (update-pos [v] - (let [start-pos (:pos @state)] - (when (string? v) - (vswap! state #(update % :pos + (count v)))) - [start-pos (:pos @state)]))] - - (^:mutable reify - basilisp.lang.interfaces/IDeref - (deref [self] - (with [_ lock] - @state)) - - ^:abstract - ^{:abstract-members #{:flush :write}} - io/TextIOBase - (write [self s] - (with [_ lock] - (if-not (seq (:buffer @state)) - (.write writer s) - (do - (let [[old-pos new-pos] (update-pos s) - blob (Blob s nil old-pos new-pos)] - (add-to-buffer blob)))) - (count s))) - - (flush [self] - (with [_ lock] - (when-let [buf (:buffer @state)] - (write-tokens buf)) - (.flush writer))) - - PrettyWriter - (start-block [self prefix suffix] - (with [_ lock] - (let [current-block (:block @state) - new-block (LogicalBlock current-block prefix suffix 0 false) - [old-pos new-pos] (update-pos prefix) - start-block (StartBlock new-block old-pos new-pos)] - (vswap! state #(-> % - (assoc :block new-block) - (assoc :pos new-pos))) - (add-to-buffer start-block))) - nil) - - (end-block [self] - (with [_ lock] - (let [{:keys [block pos]} @state - suffix (.-suffix block) - [old-pos new-pos] (update-pos suffix) - end-block (EndBlock block pos new-pos)] - (vswap! state #(assoc % :block (.-parent block))) - (add-to-buffer end-block))) - nil) - - (pp-newline [self kind] - (with [_ lock] - (let [{:keys [block pos]} @state - nl (Newline block kind pos pos)] - (add-to-buffer nl))) - nil))))) + ([writer] + (get-pretty-writer writer *print-right-margin*)) + ([writer max-columns] + (let [lock (threading/RLock) + writer (get-column-writer writer max-columns) + state (volatile! {:block (LogicalBlock nil nil nil nil 0 false) + :buffer (queue) + :pos 0})] + (letfn [;; Private helpers can only be called while the lock is held + + ;; Return `true` if the given tokens will fit on the current line given + ;; the max column width set for the base writer (if one is set). + (tokens-fit? [tokens] + (let [{:keys [col max]} @writer] + (or (nil? max) + (pos? (- max (+ col (buffer-length tokens))))))) + + ;; Set `force-nl?` on the current logical block to ensure that any + ;; remaining `:linear` newlines associated with the block are emitted. + (set-block-force-nl! [block] + (loop [block block] + (when block + (when-not (.-force-nl? block) + (set! (.-force-nl? block) true) + (recur (.-parent block)))))) + + ;; Set the `indent` of the current logical block to match the current + ;; column position of the base writer. + (set-block-indent! [block prefix] + (let [indent (+ (:col @writer) (count prefix))] + (set! (.-indent block) indent))) + + ;; Return `true` if the given newline type should be emitted. + (emit-nl? [token section] + (condp = (.-kind token) + :mandatory true + :linear (or (.-force-nl? (.-block token)) + (not (tokens-fit? section))) + ;; TODO: figure out how to handle these newline types + :fill nil + :miser nil)) + + ;; Generate the newline and subsequent indent from a newline token token. + (gen-nl [token] + (let [block (.-block token) + indent (or (.-indent block) 0) + prefix (or (.-per-line-prefix block) "")] + (set-block-force-nl! block) + (str os/linesep prefix (.ljust "" indent)))) + + ;; Write a sequence of tokens to the base writer. + (write-tokens [tokens] + (doseq [token tokens] + (when-let [s (condp instance? token + Blob (.-data token) + Newline (when (or (= (.-kind token) :mandatory) + (.-force-nl? (.-block token))) + (gen-nl token)) + StartBlock (let [block (.-block token)] + (when-let [prefix (.-prefix block)] + (set-block-indent! block prefix) + prefix)) + EndBlock (.-suffix (.-block token)))] + (.write writer s)))) + + ;; Write a single line and possibly emit a trailing conditional newline. + (write-line [] + (let [{:keys [buffer]} @state + [s buf] (split-at-newline buffer)] + #_(pdebug {:buffer (map debug-token buf) :s (map debug-token s)}) + (when (seq s) + (write-tokens s)) + (vswap! state #(assoc % :buffer buf)) + ;; check if buffer still exceeds length; if so, we'll need to emit newlines + (when buf + (let [[section remainder] (get-section buf) + ;;_ (pdebug {:section (map debug-token section) + ;; :remainder (map debug-token remainder)}) + maybe-nl (first buf) + buf (if (emit-nl? maybe-nl section) + (do + (.write writer (gen-nl maybe-nl)) + (pop buf)) + buf)] + (if-not (tokens-fit? buf) + (do + #_(pdebug "writing section " (map debug-token section)) + (write-tokens section) + (vswap! state #(assoc % :buffer remainder))) + (vswap! state #(assoc % :buffer buf))))))) + + ;; Write tokens from the buffer to the base writer as long as the tokens + ;; in the buffer won't fit on the current line. + (write-lines [] + (loop [{:keys [buffer]} @state] + (if-not (tokens-fit? buffer) + (write-line) + (when-not (identical? buffer (:buffer @state)) + (recur @state))))) + + ;; Add a token to the buffer and flush the buffer to the base writer if + ;; the tokens do not fit on the base line. + (add-to-buffer [token] + (let [{:keys [buffer]} (vswap! state #(update % :buffer conj token))] + (when-not (tokens-fit? buffer) + (write-lines)))) + + ;; Update the current position in the state based on the given value, + ;; returning a vector of the starting position and ending position. + ;; + ;; If the value is a string, the position will be incremented by the + ;; length of the string. Otherwise, the position will be unchanged. + (update-pos [v] + (let [start-pos (:pos @state)] + (when (string? v) + (vswap! state #(update % :pos + (count v)))) + [start-pos (:pos @state)]))] + + (^:mutable reify + basilisp.lang.interfaces/IDeref + (deref [self] + (with [_ lock] + @state)) + + ^:abstract + ^{:abstract-members #{:flush :write}} + io/TextIOBase + (write [self s] + (with [_ lock] + (if-not (seq (:buffer @state)) + (.write writer s) + (do + (let [[old-pos new-pos] (update-pos s) + blob (Blob s old-pos new-pos)] + (add-to-buffer blob)))) + (count s))) + + (flush [self] + (with [_ lock] + (when-let [buf (:buffer @state)] + (write-tokens buf)) + (.flush writer))) + + PrettyWriter + (start-block [self prefix per-line-prefix suffix] + (with [_ lock] + (let [current-block (:block @state) + new-block (LogicalBlock current-block prefix per-line-prefix suffix 0 false) + [old-pos new-pos] (update-pos prefix) + start-block (StartBlock new-block old-pos new-pos)] + (vswap! state #(-> % + (assoc :block new-block) + (assoc :pos new-pos))) + (add-to-buffer start-block))) + nil) + + (end-block [self] + (with [_ lock] + (let [{:keys [block pos]} @state + suffix (.-suffix block) + [old-pos new-pos] (update-pos suffix) + end-block (EndBlock block pos new-pos)] + (vswap! state #(assoc % :block (.-parent block))) + (add-to-buffer end-block))) + nil) + + (pp-newline [self kind] + (with [_ lock] + (let [{:keys [block pos]} @state + nl (Newline block kind pos pos)] + (add-to-buffer nl))) + nil)))))) ;;;;;;;;;;;;; ;; Helpers ;; ;;;;;;;;;;;;; (defmacro pprint-logical-block + "Macro for grouping logical elements together in ``pprint`` outputs." [& body] (let [flag-names #{:prefix :per-line-prefix :suffix} [flags body] (loop [flags {} @@ -415,9 +403,10 @@ (recur (assoc flags (first body) (second body)) (nthrest body 2)) [flags body]))] - `(with-bindings {#'*current-level* (inc *current-level*)} - ~(let [{:keys [prefix suffix]} flags] - `(start-block *out* ~prefix ~suffix)) + `(with-bindings {#'*current-level* (inc *current-level*) + #'*current-length* 0} + ~(let [{:keys [prefix per-line-prefix suffix]} flags] + `(start-block *out* ~prefix ~per-line-prefix ~suffix)) ~@body (end-block *out*)))) @@ -484,7 +473,7 @@ (defmethod simple-dispatch fractions/Fraction [obj] (*print-pprint-dispatch* (numerator obj)) - (print "/") + (.write *out* "/") (*print-pprint-dispatch* (denominator obj))) (defmethod simple-dispatch basilisp.lang.symbol/Symbol @@ -505,35 +494,79 @@ (pprint-newline :linear) (recur more)))))) +(defn ^:private print-map + "Print an associative collection." + [prefix suffix obj] + (pprint-logical-block :prefix prefix :suffix suffix + (print-length-loop [m obj] + (when (seq m) + (let [[k v] (first m)] + (write-out k) + (.write *out* " ") + (write-out v) + (pprint-newline :linear) + (when-let [more (seq (rest m))] + (.write *out* " ") + (recur more))))))) + +(defn ^:private print-meta + "Print the metadata associated with an object if it has any metadata and if + :lpy:var:`basilisp.core/*print-meta*` is set to a non-``nil`` value." + [obj] + (when *print-meta* + (when-let [m (meta obj)] + (.write *out* "^") + (print-map "{" "}" m) + (.write *out* " ") + (pprint-newline :linear)))) + (defmethod simple-dispatch basilisp.lang.interfaces/ISeq [obj] + (print-meta obj) (print-simple-coll "(" ")" obj)) (defmethod simple-dispatch basilisp.lang.interfaces/IPersistentList [obj] + (print-meta obj) (print-simple-coll "(" ")" obj)) +(defmethod simple-dispatch python/tuple + [obj] + (print-simple-coll "#py (" ")" obj)) + +(defmethod simple-dispatch basilisp.lang.queue/PersistentQueue + [obj] + (print-meta obj) + (print-simple-coll "#queue (" ")" obj)) + +(prefer-method simple-dispatch basilisp.lang.interfaces/IPersistentList basilisp.lang.interfaces/ISeq) + (defmethod simple-dispatch basilisp.lang.interfaces/IPersistentSet [obj] + (print-meta obj) (print-simple-coll "#{" "}" obj)) +(defmethod simple-dispatch python/set + [obj] + (print-simple-coll "#py #{" "}" obj)) + (defmethod simple-dispatch basilisp.lang.interfaces/IPersistentVector [obj] + (print-meta obj) (print-simple-coll "[" "]" obj)) +(defmethod simple-dispatch python/list + [obj] + (print-simple-coll "#py [" "]" obj)) + (defmethod simple-dispatch basilisp.lang.interfaces/IPersistentMap [obj] - (pprint-logical-block :prefix "{" :suffix "}" - (print-length-loop [m obj] - (when (seq m) - (let [[k v] (first m)] - (write-out k) - (.write *out* " ") - (write-out v) - (pprint-newline :linear) - (when-let [more (seq (rest m))] - (.write *out* " ") - (recur more))))))) + (print-meta obj) + (print-map "{" "}" obj)) + +(defmethod simple-dispatch python/dict + [obj] + (print-map "#py {" "}" (.items obj))) (alter-var-root #'*print-pprint-dispatch* (constantly simple-dispatch)) diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index fad7331ca..45ed4c22b 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -38,7 +38,130 @@ ":long.ns/kw" :long.ns/kw "sym" 'sym "ns/sym" 'ns/sym - "long.ns/sym" 'long.ns/sym))) + "long.ns/sym" 'long.ns/sym)) + + (testing "collections" + (are [res expr] (= res (str/rtrim (with-out-str (pprint/pprint expr)))) + "{}" {} + "{:a 1}" {:a 1} + + "()" '() + "(:a)" '(:a) + "(:a 1)" '(:a 1) + + "#queue ()" (queue) + "#queue (:a)" (queue [:a]) + "#queue (:a 1)" (queue [:a 1]) + + "(:a)" (seq [:a]) + "(:a 1)" (seq [:a 1]) + + "[]" [] + "[:a]" [:a] + "[:a 1]" [:a 1] + + "#{}" #{} + "#{:a}" #{:a})) + + (testing "python collections" + (are [res expr] (= res (str/rtrim (with-out-str (pprint/pprint expr)))) + "#py {}" (python/dict) + "#py {:a 1}" (python/dict {:a 1}) + + "#py ()" (python/tuple) + "#py (:a)" (python/tuple [:a]) + "#py (:a 1)" (python/tuple [:a 1]) + + "#py []" (python/list) + "#py [:a]" (python/list [:a]) + "#py [:a 1]" (python/list [:a 1]) + + "#py #{}" (python/set) + "#py #{:a}" (python/set [:a]))) + + (testing "large collections" + (are [res expr] (= res (str/rtrim (with-out-str (pprint/pprint expr)))) + "[(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) + (21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39) + :a + :b + :c + (41 + 42 + 43 + 44 + 45 + 46 + 47 + 48 + 49 + 50 + 51 + 52 + 53 + 54 + 55 + 56 + 57 + 58 + 59 + 60 + 61 + 62 + 63 + 64 + 65 + 66 + 67 + 68 + 69 + 70 + 71 + 72 + 73 + 74 + 75 + 76 + 77 + 78 + 79) + (81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99)]" + (vector (range 20) (range 21 40) :a :b :c (range 41 80) (range 81 100)))) + + (testing "printing meta" + (are [res expr] (= res (str/rtrim + (binding [*print-meta* true] + (with-out-str (pprint/pprint expr))))) + "[]" [] + "^{:a 1} []" ^{:a 1} [] + "^{:a true} [:a 1]" ^:a [:a 1] + + "()" '() + "^{:a 1} ()" '^{:a 1} () + "^{:a true} ()" '^:a () + + "{}" {} + "^{:b 2} {:a 1}" ^{:b 2} {:a 1} + "^{:b true} {:a 1}" ^:b {:a 1} + + "#{}" #{} + "^{:a 1} #{:a}" ^{:a 1} #{:a} + "^{:a true} #{:a}" ^:a #{:a}))) + +(deftest print-length-test + (are [res plen expr] (= res (str/rtrim + (binding [*print-length* plen] + (with-out-str + (pprint/pprint expr))))) + "(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ...)" 20 (range 50) + "((0 1 2 3 4 ...) + (0 1 2 3 4 ...) + (0 1 2 3 4 ...) + (0 1 2 3 4 ...) + (0 1 2 3 4 ...) + ...)" + 5 + (repeat 10 (range 10)))) (deftest pprint-suppress-namespaces-test (testing "no supression" From 716987d1e419cfbbeb227aa668a2226698af233f Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Mon, 2 Jun 2025 20:00:53 -0400 Subject: [PATCH 05/29] IDeref related changes --- src/basilisp/pprint.lpy | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 2917eff96..883e273a7 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -66,7 +66,7 @@ ;; Column Writer ;; ;;;;;;;;;;;;;;;;;;; -(defmacro pdebug +(defmacro ^:private pdebug [& args] `(do (.write *err* (str ~@args)) From 0a6eee2acaa4ab42be6ceafdd6e8c61377a77cfc Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Mon, 2 Jun 2025 20:13:07 -0400 Subject: [PATCH 06/29] IDeref pprint --- src/basilisp/pprint.lpy | 14 +++++++++++++ tests/basilisp/test_pprint.lpy | 36 +++++++++++++++++++++++++++++++++- 2 files changed, 49 insertions(+), 1 deletion(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 883e273a7..6130cb305 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -568,6 +568,20 @@ [obj] (print-map "#py {" "}" (.items obj))) +(defmethod simple-dispatch basilisp.lang.interfaces/IDeref + [obj] + (let [classname (.-__name__ (.-__class__ obj)) + mem-addr (python/hex (python/id obj)) + prefix (str "#<" classname "@" mem-addr ": ") + contents (cond + (and (future? obj) + (not (future-done? obj))) :pending + (and (instance? basilisp.lang.interfaces/IPending obj) + (not (realized? obj))) :not-delivered + :else @obj)] + (pprint-logical-block :prefix prefix :suffix ">" + (write-out contents)))) + (alter-var-root #'*print-pprint-dispatch* (constantly simple-dispatch)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index 45ed4c22b..06d989d1b 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -148,7 +148,41 @@ "^{:a 1} #{:a}" ^{:a 1} #{:a} "^{:a true} #{:a}" ^:a #{:a}))) -(deftest print-length-test +(defn ^:private match-ideref + [v] + (let [s (with-out-str (pprint/pprint v))] + (drop 1 (re-matches #"#<(\w+)@0x[0-9a-f]+: ([^>]+)>\r?\n" s)))) + +(deftest pprint-ideref-test + (testing "delay" + (let [d (delay :delayed)] + (is (= ["Delay" ":not-delivered"] (match-ideref d))) + @d + (is (= ["Delay" ":delayed"] (match-ideref d))))) + + (testing "future" + (let [p (promise) + f (future + @p + 1)] + (is (= ["Future" ":pending"] (match-ideref f))) + (deliver p :anything) + @f + (is (= ["Future" "1"] (match-ideref f))))) + + (testing "promise" + (let [p (promise)] + (is (= ["Promise" ":not-delivered"] (match-ideref p))) + (deliver p :delivered) + (is (= ["Promise" ":delivered"] (match-ideref p))))) + + (testing "volatile" + (let [v (volatile! nil)] + (is (= ["Volatile" "nil"] (match-ideref v))) + (vreset! v :not-nil) + (is (= ["Volatile" ":not-nil"] (match-ideref v)))))) + +(deftest pprint-print-length-test (are [res plen expr] (= res (str/rtrim (binding [*print-length* plen] (with-out-str From c1ab102085dd51ec993beec8ebfef47acdc4ee72 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Mon, 2 Jun 2025 20:23:07 -0400 Subject: [PATCH 07/29] More test --- src/basilisp/pprint.lpy | 3 ++- tests/basilisp/test_pprint.lpy | 5 +++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 6130cb305..3039ca1d0 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -17,6 +17,7 @@ ;; - miser and fill newlines ;; - indent controls ;; - arbitrary base printing for integers +;; - cycle detection (declare simple-dispatch code-dispatch write-out) @@ -290,7 +291,7 @@ (write-tokens s)) (vswap! state #(assoc % :buffer buf)) ;; check if buffer still exceeds length; if so, we'll need to emit newlines - (when buf + (when (seq buf) (let [[section remainder] (get-section buf) ;;_ (pdebug {:section (map debug-token section) ;; :remainder (map debug-token remainder)}) diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index 06d989d1b..e78d94e0f 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -153,6 +153,8 @@ (let [s (with-out-str (pprint/pprint v))] (drop 1 (re-matches #"#<(\w+)@0x[0-9a-f]+: ([^>]+)>\r?\n" s)))) +(def ^:private ideref-value :var) + (deftest pprint-ideref-test (testing "delay" (let [d (delay :delayed)] @@ -176,6 +178,9 @@ (deliver p :delivered) (is (= ["Promise" ":delivered"] (match-ideref p))))) + (testing "var" + (is (= ["Var" ":var"] (match-ideref ideref-value)))) + (testing "volatile" (let [v (volatile! nil)] (is (= ["Volatile" "nil"] (match-ideref v))) From 37530064fa1e70e4a0a06befb7c9b84736ff2185 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Mon, 2 Jun 2025 21:59:35 -0400 Subject: [PATCH 08/29] Handle arbitrary positive integer bases --- src/basilisp/pprint.lpy | 74 ++++++++++++++++++++++++++++------ tests/basilisp/test_pprint.lpy | 28 ++++++++++++- 2 files changed, 88 insertions(+), 14 deletions(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 3039ca1d0..cfd770518 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -16,7 +16,6 @@ ;; TODO: ;; - miser and fill newlines ;; - indent controls -;; - arbitrary base printing for integers ;; - cycle detection (declare simple-dispatch code-dispatch write-out) @@ -43,6 +42,14 @@ *print-pretty* false) +(def ^{:doc "If bound to ``true``, integers and rationals will be printed with a radix + prefix. For bases 2, 8, and 16 the prefix will be ``#b``, ``#o`` and ``#x`` + respectively. All other bases will be specified as ``#XXr`` where ``XX`` is + the decimal value of :lpy:var:`*print-base*`." + :dynamic true} + *print-radix* + false) + (def ^{:doc "The soft upper limit for the length of the right margin. Default is 72." :dynamic true} *print-right-margin* @@ -447,6 +454,54 @@ ;; Simple Dispatch ;; ;;;;;;;;;;;;;;;;;;;;; +(defn ^:private base-chr + "Return the appropriate character for an integer offset from the starting + character of the alphabet. + + Uses ``0`` to ``9``, all lowercase Latin characters, and continues into + UTF-8." + [v] + (python/chr + (if (< v 10) + (+ (python/ord "0") v) + (+ (python/ord "a") (- v 10))))) + +(defn ^:private int->base + "Convert integer ``n`` to a string of the given ``base``." + [n base] + (if (zero? n) + "0" + (loop [v n + c []] + (if (pos? v) + (recur (operator/floordiv v base) + (conj c (base-chr (mod v base)))) + (.join "" (rseq c)))))) + +(defn ^:private format-int + "Format an integer value ``n`` subject to the rules of both :lpy:var:`*print-base*` + and :lpy:var:`*print-radix*`." + [n] + (let [base *print-base* + radix-prefix (if *print-radix* + (case base + 2 "#b" + 8 "#o" + 16 "#x" + 10 "" + (.format "#{}r" base)) + "") + format-str (case base + 2 "{0:b}" + 8 "{0:o}" + 10 "{}" + 16 "{0:x}" + nil)] + (str radix-prefix + (if format-str + (.format format-str n) + (int->base n base))))) + (defmulti simple-dispatch type) (defmethod simple-dispatch :default @@ -455,15 +510,7 @@ (defmethod simple-dispatch python/int [obj] - (if-let [base (case *print-base* - 2 "{0:b}" - 8 "{0:o}" - 10 "{}" - 16 "{0:x}" - nil)] - (print (.format base obj)) - (throw - (ex-info "Invalid integral base" {:base *print-base*})))) + (.write *out* (format-int obj))) ;; This `python/bool` override is required because Python `bool` types are also ;; instances of `python/int`, so they will be caught by the `int` dispatch otherwise. @@ -473,9 +520,10 @@ (defmethod simple-dispatch fractions/Fraction [obj] - (*print-pprint-dispatch* (numerator obj)) - (.write *out* "/") - (*print-pprint-dispatch* (denominator obj))) + (.write *out* + (str (format-int (numerator obj)) + "/" + (format-int (denominator obj))))) (defmethod simple-dispatch basilisp.lang.symbol/Symbol [obj] diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index e78d94e0f..4e7c29202 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -148,6 +148,32 @@ "^{:a 1} #{:a}" ^{:a 1} #{:a} "^{:a true} #{:a}" ^:a #{:a}))) +(deftest pprint-base-and-radix-test + (are [res base expr] (= res (str/rtrim + (binding [pprint/*print-radix* true + pprint/*print-base* base] + (with-out-str + (pprint/pprint expr))))) + "0" 10 0 + "1" 10 1 + "-1" 10 -1 + + "#b0" 2 0 + "#b1" 2 1 + "#b10" 2 2 + + "#o0" 8 0 + "#o1" 8 1 + "#o14" 8 12 + + "#x0" 16 0 + "#x1" 16 1 + "#x1b" 16 27 + + "#18r0" 18 0 + "#18r1" 18 1 + "#18r27" 18 43)) + (defn ^:private match-ideref [v] (let [s (with-out-str (pprint/pprint v))] @@ -179,7 +205,7 @@ (is (= ["Promise" ":delivered"] (match-ideref p))))) (testing "var" - (is (= ["Var" ":var"] (match-ideref ideref-value)))) + (is (= ["Var" ":var"] (match-ideref #'ideref-value)))) (testing "volatile" (let [v (volatile! nil)] From e35a486348139cb6f2e77fea2346ddc611f1559c Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Mon, 2 Jun 2025 22:00:57 -0400 Subject: [PATCH 09/29] Changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 4908a437a..e9ee49858 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -13,6 +13,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 * Added support for f-strings (#922) * Added the `aslice` macro to facilitate the use of Python style `array[start:stop:step]` slicing in Basilisp (#1248) * Added the `IPending` interface which is implemented by delays, futures, and promises (#1260) + * Added the `basilisp.pprint` namespace (#513) ### Changed * Removed implicit support for single-use iterables in sequences, and introduced `iterator-seq` to expliciltly handle them (#1192) From f8b3ed4b65b22298ce679e8533de967d22537c6b Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Mon, 2 Jun 2025 22:06:07 -0400 Subject: [PATCH 10/29] Use `repr` rather than a custom fn --- src/basilisp/pprint.lpy | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index cfd770518..829132345 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -132,23 +132,23 @@ (__repr__ [self] (str [(python/id self) (python/repr parent) prefix suffix indent force-nl?]))) -(deftype StartBlock [block start end]) +(deftype StartBlock [block start end] + (__repr__ [self] + (str [:start (python/id block)]))) -(deftype EndBlock [block start end]) +(deftype EndBlock [block start end] + (__repr__ [self] + (str [:end (python/id block)]))) -(deftype Blob [data start end]) +(deftype Blob [data start end] + (__repr__ [self] + data)) (deftype Indent [block relative-to offset start end]) -(deftype Newline [block kind start end]) - -(defn debug-token - [token] - (condp instance? token - StartBlock [":start" (python/id (.-block token))] - EndBlock [":end" (python/id (.-block token))] - Blob (.-data token) - Newline [(.-kind token) (python/id (.-block token))])) +(deftype Newline [block kind start end] + (__repr__ [self] + (str [kind (python/id block)]))) ;;;;;;;;;;;;;;;;;;; ;; Pretty Writer ;; @@ -293,15 +293,15 @@ (write-line [] (let [{:keys [buffer]} @state [s buf] (split-at-newline buffer)] - #_(pdebug {:buffer (map debug-token buf) :s (map debug-token s)}) + #_(pdebug {:buffer (map repr buf) :s (map repr s)}) (when (seq s) (write-tokens s)) (vswap! state #(assoc % :buffer buf)) ;; check if buffer still exceeds length; if so, we'll need to emit newlines (when (seq buf) (let [[section remainder] (get-section buf) - ;;_ (pdebug {:section (map debug-token section) - ;; :remainder (map debug-token remainder)}) + ;;_ (pdebug {:section (map repr section) + ;; :remainder (map repr remainder)}) maybe-nl (first buf) buf (if (emit-nl? maybe-nl section) (do @@ -310,7 +310,7 @@ buf)] (if-not (tokens-fit? buf) (do - #_(pdebug "writing section " (map debug-token section)) + #_(pdebug "writing section " (map repr section)) (write-tokens section) (vswap! state #(assoc % :buffer remainder))) (vswap! state #(assoc % :buffer buf))))))) From 929d9a3a006f52e414e78a62e7f1ffaae87144ad Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Mon, 2 Jun 2025 22:17:55 -0400 Subject: [PATCH 11/29] Cycle detection --- src/basilisp/pprint.lpy | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 829132345..2248021ad 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -16,7 +16,6 @@ ;; TODO: ;; - miser and fill newlines ;; - indent controls -;; - cycle detection (declare simple-dispatch code-dispatch write-out) @@ -637,6 +636,8 @@ ;; Pretty Printing Public API ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(def ^:private ^:dynamic *context* #{}) + (defn write-out [object] (let [length-reached? (and *current-length* @@ -648,7 +649,13 @@ (do (when-let [l *current-length*] (set! *current-length* (inc l))) - (*print-pprint-dispatch* object))) + (let [obj-id (python/id object)] + (if (contains? *context* obj-id) + (print (.format "" + (.-__name__ (class object)) + (python/hex obj-id))) + (binding [*context* (conj *context* obj-id)] + (*print-pprint-dispatch* object)))))) (pr object)))) (defn pprint From 45c02234b29d6d128691cfc991251bb81c83e5e8 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Tue, 3 Jun 2025 20:04:44 -0400 Subject: [PATCH 12/29] Documentation --- src/basilisp/pprint.lpy | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 2248021ad..c3f4d5499 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -636,9 +636,23 @@ ;; Pretty Printing Public API ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(def ^:private ^:dynamic *context* #{}) +;; Calls to `write-out` will add object IDs (per `python/id`) to the `*recursion-context*` +;; and check that context on recursive calls, allowing for cycle detection in pretty +;; printed output. +(def ^:private ^:dynamic *recursion-context* #{}) (defn write-out + "Write ``object`` to :lpy:fn:`basilisp.core/*out*`, respecting the current bindings + of the pretty printing control variables. + + ``*out*`` should be a pretty writer (as returned by :lpy:fn:`get-pretty-writer`). + + This function is intended to be called from within pretty print dispatch functions + which already have pretty print control variables correctly set up. + + .. note:: + + This function performs cycle detection on input values." [object] (let [length-reached? (and *current-length* *print-length* @@ -650,11 +664,11 @@ (when-let [l *current-length*] (set! *current-length* (inc l))) (let [obj-id (python/id object)] - (if (contains? *context* obj-id) + (if (contains? *recursion-context* obj-id) (print (.format "" (.-__name__ (class object)) (python/hex obj-id))) - (binding [*context* (conj *context* obj-id)] + (binding [*recursion-context* (conj *recursion-context* obj-id)] (*print-pprint-dispatch* object)))))) (pr object)))) From 74bcb290bb139a2eaf18cbd9771a142649414517 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Tue, 3 Jun 2025 20:34:26 -0400 Subject: [PATCH 13/29] level --- src/basilisp/pprint.lpy | 21 ++++++++++++--------- tests/basilisp/test_pprint.lpy | 10 ++++++++++ 2 files changed, 22 insertions(+), 9 deletions(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index c3f4d5499..fddd74d0a 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -410,12 +410,14 @@ (recur (assoc flags (first body) (second body)) (nthrest body 2)) [flags body]))] - `(with-bindings {#'*current-level* (inc *current-level*) - #'*current-length* 0} - ~(let [{:keys [prefix per-line-prefix suffix]} flags] - `(start-block *out* ~prefix ~per-line-prefix ~suffix)) - ~@body - (end-block *out*)))) + `(if (and *print-level* (>= *current-level* *print-level*)) + (.write *out* "#") + (with-bindings {#'*current-level* (inc *current-level*) + #'*current-length* 0} + ~(let [{:keys [prefix per-line-prefix suffix]} flags] + `(start-block *out* ~prefix ~per-line-prefix ~suffix)) + ~@body + (end-block *out*))))) (defmacro print-length-loop ":lpy:fn:`loop` -like macro which loops at most :lpy:fn:`basilisp.core/*print-length*` @@ -437,9 +439,10 @@ (defn pprint-newline "Emit a newline to the output buffer. - ``:kind`` must be one of the following: - - ``:linear`` - - ``:mandatory`` + ``kind`` must be one of the following keywords: + - ``:linear``, which will be emitted as newlines only if the the logical block + doesn't fit on one line + - ``:mandatory``, which the pretty writer will emit in all cases - ``:miser`` - ``:fill``" [kind] diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index 4e7c29202..8f46d75e4 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -213,6 +213,16 @@ (vreset! v :not-nil) (is (= ["Volatile" ":not-nil"] (match-ideref v)))))) +(deftest pprint-print-level-test + (are [res plen expr] (= res (str/rtrim + (binding [*print-level* plen] + (with-out-str + (pprint/pprint expr))))) + "#" 0 [] + "[#]" 1 [[]] + "[[#]]" 2 [[[]]] + "[[:a :b :c] [#]]" 2 [[:a :b :c] [[]]])) + (deftest pprint-print-length-test (are [res plen expr] (= res (str/rtrim (binding [*print-length* plen] From 964133a99a8277143ee70a66bd4f20cdbed11bbb Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Tue, 3 Jun 2025 20:57:21 -0400 Subject: [PATCH 14/29] Test recursion check --- tests/basilisp/test_pprint.lpy | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index 8f46d75e4..3e2758746 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -238,6 +238,14 @@ 5 (repeat 10 (range 10)))) +(deftest pprint-recursion-check + (let [a (atom []) + b (atom {:a a})] + (swap! a conj b) + (let [s (with-out-str + (pprint/pprint a))] + (is (not (nil? (re-find #"" s))))))) + (deftest pprint-suppress-namespaces-test (testing "no supression" (are [res expr] (= res (str/rtrim (with-out-str (pprint/pprint expr)))) From 8293f0d81653c5abafec6eea75a898126a666719 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Tue, 3 Jun 2025 22:11:18 -0400 Subject: [PATCH 15/29] Indent controls --- src/basilisp/pprint.lpy | 63 +++++++++++++++++++++++++++------- tests/basilisp/test_pprint.lpy | 40 ++++++++++++++++++++- 2 files changed, 89 insertions(+), 14 deletions(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index fddd74d0a..ec17cd2b8 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -15,7 +15,6 @@ ;; TODO: ;; - miser and fill newlines -;; - indent controls (declare simple-dispatch code-dispatch write-out) @@ -127,7 +126,9 @@ ;; Types ;; ;;;;;;;;;;; -(deftype LogicalBlock [parent prefix per-line-prefix suffix ^:mutable indent ^:mutable force-nl?] +;; `indent` may be changed later by an indent token, whereas `start-col` is fixed at +;; the point the start block token is encountered in the stream. +(deftype LogicalBlock [parent prefix per-line-prefix suffix ^:mutable indent ^:mutable start-col ^:mutable force-nl?] (__repr__ [self] (str [(python/id self) (python/repr parent) prefix suffix indent force-nl?]))) @@ -143,7 +144,9 @@ (__repr__ [self] data)) -(deftype Indent [block relative-to offset start end]) +(deftype Indent [block relative-to offset start end] + (__repr__ [self] + (str [(python/id block) relative-to offset]))) (deftype Newline [block kind start end] (__repr__ [self] @@ -217,6 +220,7 @@ (defprotocol PrettyWriter (start-block [this prefix per-line-prefix suffix]) (end-block [this]) + (pp-indent [this relative-to offset]) (pp-newline [this kind])) (defn get-pretty-writer @@ -228,7 +232,7 @@ ([writer max-columns] (let [lock (threading/RLock) writer (get-column-writer writer max-columns) - state (volatile! {:block (LogicalBlock nil nil nil nil 0 false) + state (volatile! {:block (LogicalBlock nil nil nil nil 0 0 false) :buffer (queue) :pos 0})] (letfn [;; Private helpers can only be called while the lock is held @@ -249,11 +253,12 @@ (set! (.-force-nl? block) true) (recur (.-parent block)))))) - ;; Set the `indent` of the current logical block to match the current - ;; column position of the base writer. - (set-block-indent! [block prefix] + ;; Set the `indent` and `start-col` of the current logical block to match + ;; the current column position of the base writer. + (set-block-cols! [block prefix] (let [indent (+ (:col @writer) (count prefix))] - (set! (.-indent block) indent))) + (set! (.-indent block) indent) + (set! (.-start-col block) indent))) ;; Return `true` if the given newline type should be emitted. (emit-nl? [token section] @@ -281,10 +286,17 @@ Newline (when (or (= (.-kind token) :mandatory) (.-force-nl? (.-block token))) (gen-nl token)) - StartBlock (let [block (.-block token)] - (when-let [prefix (.-prefix block)] - (set-block-indent! block prefix) - prefix)) + Indent (let [block (.-block token) + indent (+ (.-offset token) + (case (.-relative-to token) + :block (.-start-col block) + :current (:col @writer)))] + (set! (.-indent block) indent) + nil) + StartBlock (let [block (.-block token) + prefix (.-prefix block)] + (set-block-cols! block (or prefix "")) + prefix) EndBlock (.-suffix (.-block token)))] (.write writer s)))) @@ -370,7 +382,7 @@ (start-block [self prefix per-line-prefix suffix] (with [_ lock] (let [current-block (:block @state) - new-block (LogicalBlock current-block prefix per-line-prefix suffix 0 false) + new-block (LogicalBlock current-block prefix per-line-prefix suffix 0 0 false) [old-pos new-pos] (update-pos prefix) start-block (StartBlock new-block old-pos new-pos)] (vswap! state #(-> % @@ -389,6 +401,13 @@ (add-to-buffer end-block))) nil) + (pp-indent [self relative-to offset] + (with [_ lock] + (let [{:keys [block pos]} @state + indent (Indent block relative-to offset pos pos)] + (add-to-buffer indent))) + nil) + (pp-newline [self kind] (with [_ lock] (let [{:keys [block pos]} @state @@ -436,6 +455,22 @@ (do ~@body) (.write *out* "..."))))) +(defn pprint-indent + "Configure the indent of `offset` characters relative to an anchor at this point + in the pretty print output. + + ``relative-to`` must be one of the following keywords: + - ``:current``, meaning that the indent offset is relative to the current column + when the indent token is encountered + - ``:block``, meaning that the indent offset is relative to the starting column of + the current logical block" + [relative-to offset] + (when-not (#{:block :current} relative-to) + (throw + (ex-info "relative-to must be one of: :block, :current" + {:relative-to relative-to}))) + (pp-indent *out* relative-to offset)) + (defn pprint-newline "Emit a newline to the output buffer. @@ -631,6 +666,8 @@ (not (realized? obj))) :not-delivered :else @obj)] (pprint-logical-block :prefix prefix :suffix ">" + (pprint-indent :block (- (- (count prefix) 2))) + (pprint-newline :linear) (write-out contents)))) (alter-var-root #'*print-pprint-dispatch* (constantly simple-dispatch)) diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index 3e2758746..e9e834999 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -211,7 +211,45 @@ (let [v (volatile! nil)] (is (= ["Volatile" "nil"] (match-ideref v))) (vreset! v :not-nil) - (is (= ["Volatile" ":not-nil"] (match-ideref v)))))) + (is (= ["Volatile" ":not-nil"] (match-ideref v))))) + + (testing "long values" + (let [v (volatile! (range 5))] + (is (= ["Volatile" "(0 1 2 3 4)"] (match-ideref v))) + (vreset! v (range 25)) + (is (= ["Volatile" "\n (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24)"] (match-ideref v))) + (vreset! v (range 30)) + (is (= ["Volatile" " + (0 + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 11 + 12 + 13 + 14 + 15 + 16 + 17 + 18 + 19 + 20 + 21 + 22 + 23 + 24 + 25 + 26 + 27 + 28 + 29)"] (match-ideref v)))))) (deftest pprint-print-level-test (are [res plen expr] (= res (str/rtrim From cc39dbd9796001a68920fd133b522cd596de4895 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Wed, 4 Jun 2025 20:29:19 -0400 Subject: [PATCH 16/29] More tests and fixes --- src/basilisp/pprint.lpy | 21 ++++++++------------- tests/basilisp/test_pprint.lpy | 12 ++++++++---- 2 files changed, 16 insertions(+), 17 deletions(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index ec17cd2b8..3f1cbe2fe 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -206,15 +206,9 @@ [buffer] (let [nl (first buffer) block (.-block nl) - ;;_ (pdebug "nl-block=" (python/id (.-block nl)) " " (.-block nl)) comparator (fn [token] - (if (instance? Newline token) - (let [is-ancestor? (ancestor? (.-block token) block)] - #_(pdebug "token=" [(.-kind token) (.-block token)] - " block=" block - " is-ancestor?=" is-ancestor?) - is-ancestor?) - false))] + (and (instance? Newline token) + (ancestor? (.-block token) block)))] (split-queue-with comparator (pop buffer)))) (defprotocol PrettyWriter @@ -300,19 +294,16 @@ EndBlock (.-suffix (.-block token)))] (.write writer s)))) - ;; Write a single line and possibly emit a trailing conditional newline. + ;; Write a single line and possibly emit a conditional newline. (write-line [] (let [{:keys [buffer]} @state [s buf] (split-at-newline buffer)] - #_(pdebug {:buffer (map repr buf) :s (map repr s)}) (when (seq s) (write-tokens s)) (vswap! state #(assoc % :buffer buf)) ;; check if buffer still exceeds length; if so, we'll need to emit newlines (when (seq buf) (let [[section remainder] (get-section buf) - ;;_ (pdebug {:section (map repr section) - ;; :remainder (map repr remainder)}) maybe-nl (first buf) buf (if (emit-nl? maybe-nl section) (do @@ -321,7 +312,6 @@ buf)] (if-not (tokens-fit? buf) (do - #_(pdebug "writing section " (map repr section)) (write-tokens section) (vswap! state #(assoc % :buffer remainder))) (vswap! state #(assoc % :buffer buf))))))) @@ -654,6 +644,11 @@ [obj] (print-map "#py {" "}" (.items obj))) +;; Disambiguate `Var` from `IDeref` +(defmethod simple-dispatch basilisp.lang.runtime/Var + [obj] + (pr obj)) + (defmethod simple-dispatch basilisp.lang.interfaces/IDeref [obj] (let [classname (.-__name__ (.-__class__ obj)) diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index e9e834999..5c3c635b0 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -128,6 +128,12 @@ (81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99)]" (vector (range 20) (range 21 40) :a :b :c (range 41 80) (range 81 100)))) + (testing "printing collections with long elements" + (is (= "[\"abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc\"]\n" + (with-out-str + (pprint/pprint + ["abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc"]))))) + (testing "printing meta" (are [res expr] (= res (str/rtrim (binding [*print-meta* true] @@ -179,7 +185,8 @@ (let [s (with-out-str (pprint/pprint v))] (drop 1 (re-matches #"#<(\w+)@0x[0-9a-f]+: ([^>]+)>\r?\n" s)))) -(def ^:private ideref-value :var) +(deftest pprint-var-test + (is (= "#'basilisp.core/map\n" (with-out-str (pprint/pprint #'map))))) (deftest pprint-ideref-test (testing "delay" @@ -204,9 +211,6 @@ (deliver p :delivered) (is (= ["Promise" ":delivered"] (match-ideref p))))) - (testing "var" - (is (= ["Var" ":var"] (match-ideref #'ideref-value)))) - (testing "volatile" (let [v (volatile! nil)] (is (= ["Volatile" "nil"] (match-ideref v))) From c870999531c57adcb569c5f5f49319ef4a57aaa1 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Wed, 4 Jun 2025 20:54:06 -0400 Subject: [PATCH 17/29] Map tests --- src/basilisp/pprint.lpy | 36 +++++++++++++++++++++++----------- tests/basilisp/test_pprint.lpy | 28 ++++++++++++++++++++++++++ 2 files changed, 53 insertions(+), 11 deletions(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 3f1cbe2fe..f0424c70b 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -53,6 +53,12 @@ *print-right-margin* 72) +(def ^{:doc "If bound to ``true``, associative collections will be printed in sorted + order by their keys. Default is ``false``." + :dynamic true} + *print-sort-keys* + false) + (def ^{:doc "If ``true``, suppress printing symbol namespaces. This may be useful when printing macroexpansions. @@ -573,17 +579,25 @@ (defn ^:private print-map "Print an associative collection." [prefix suffix obj] - (pprint-logical-block :prefix prefix :suffix suffix - (print-length-loop [m obj] - (when (seq m) - (let [[k v] (first m)] - (write-out k) - (.write *out* " ") - (write-out v) - (pprint-newline :linear) - (when-let [more (seq (rest m))] - (.write *out* " ") - (recur more))))))) + (let [coll (if *print-sort-keys* + (sort-by key obj) + obj)] + (pprint-logical-block :prefix prefix :suffix suffix + (print-length-loop [m coll] + (when (seq m) + (let [[k v] (first m)] + (pprint-logical-block + (write-out k) + (.write *out* " ") + (pprint-newline :linear) + ;; set the current length such that we won't print + ;; only a key without it's corresponding value + (binding [*current-length* (dec *current-length*)] + (write-out v))) + (when-let [more (seq (rest m))] + (.write *out* " ") + (pprint-newline :linear) + (recur more)))))))) (defn ^:private print-meta "Print the metadata associated with an object if it has any metadata and if diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index 5c3c635b0..fbc621de5 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -154,6 +154,34 @@ "^{:a 1} #{:a}" ^{:a 1} #{:a} "^{:a true} #{:a}" ^:a #{:a}))) +(deftest pprint-print-associative-test + (let [long-map (into {} (map #(vector (keyword (python/chr %1)) %2) + (range (python/ord "a") (python/ord "z")) + (range)))] + (are [res len expr] (= res (str/rtrim + (binding [pprint/*print-sort-keys* true + *print-length* len] + (with-out-str + (pprint/pprint expr))))) + "{...}" 0 long-map + "{:a 0 ...}" 1 long-map + "{:a 0 + :b 1 + :c 2 + :d 3 + :e 4 + :f 5 + :g 6 + :h 7 + :i 8 + :j 9 + :k 10 + :l 11 + :m 12 + :n 13 + :o 14 + ...}" 15 long-map))) + (deftest pprint-base-and-radix-test (are [res base expr] (= res (str/rtrim (binding [pprint/*print-radix* true From 4bed7f96a47089815ef55fb1f32778dc3b934363 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Wed, 4 Jun 2025 21:54:45 -0400 Subject: [PATCH 18/29] Miser --- src/basilisp/pprint.lpy | 62 ++++++++++++++++++++++++++--------------- 1 file changed, 40 insertions(+), 22 deletions(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index f0424c70b..8c0c48806 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -14,7 +14,7 @@ threading)) ;; TODO: -;; - miser and fill newlines +;; - fill newlines (declare simple-dispatch code-dispatch write-out) @@ -27,6 +27,16 @@ *print-base* 10) +(def ^{:doc "The text column number to start using miser style. + + Not all dispatch functions support using a miser style, so the effect + of this value depends on the value of :lpy:var:`*print-pprint-dispatch*`. + + Default is 40. May be set to ``nil`` to disable." + :dynamic true} + *print-miser-width* + 40) + (def ^{:doc "The dispatch function used for pretty printing. Default is :lpy:fn:`simple-dispatch`." @@ -260,15 +270,24 @@ (set! (.-indent block) indent) (set! (.-start-col block) indent))) + ;; Return `true` if a `:linear` newline type should be emitted. + (emit-linear-nl? [token section] + (or (.-force-nl? (.-block token)) + (not (tokens-fit? section)))) + ;; Return `true` if the given newline type should be emitted. (emit-nl? [token section] (condp = (.-kind token) :mandatory true - :linear (or (.-force-nl? (.-block token)) - (not (tokens-fit? section))) + :linear (emit-linear-nl? token section) + :miser (let [miser-width *print-miser-width* + max-col (:max @writer)] + (and miser-width + max-col + (>= (.-start-col (.-block token)) (- max miser-width)) + (emit-linear-nl? token section))) ;; TODO: figure out how to handle these newline types - :fill nil - :miser nil)) + :fill nil)) ;; Generate the newline and subsequent indent from a newline token token. (gen-nl [token] @@ -703,23 +722,22 @@ This function performs cycle detection on input values." [object] - (let [length-reached? (and *current-length* - *print-length* - (>= *current-length* *print-length*))] - (if *print-pretty* - (if length-reached? - (print "...") - (do - (when-let [l *current-length*] - (set! *current-length* (inc l))) - (let [obj-id (python/id object)] - (if (contains? *recursion-context* obj-id) - (print (.format "" - (.-__name__ (class object)) - (python/hex obj-id))) - (binding [*recursion-context* (conj *recursion-context* obj-id)] - (*print-pprint-dispatch* object)))))) - (pr object)))) + (if *print-pretty* + (if (and *current-length* + *print-length* + (>= *current-length* *print-length*)) + (print "...") + (do + (when-let [l *current-length*] + (set! *current-length* (inc l))) + (let [obj-id (python/id object)] + (if (contains? *recursion-context* obj-id) + (print (.format "" + (.-__name__ (class object)) + (python/hex obj-id))) + (binding [*recursion-context* (conj *recursion-context* obj-id)] + (*print-pprint-dispatch* object)))))) + (pr object))) (defn pprint "Pretty print ``object`` to the given ``writer``. From e5003e74f67c284874dbf1af0a85ab252989aac5 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Thu, 5 Jun 2025 19:23:29 -0400 Subject: [PATCH 19/29] Miser width tests --- src/basilisp/pprint.lpy | 4 ++-- tests/basilisp/test_pprint.lpy | 35 ++++++++++++++++++++++++++++++++++ 2 files changed, 37 insertions(+), 2 deletions(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 8c0c48806..369d0fb44 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -162,7 +162,7 @@ (deftype Indent [block relative-to offset start end] (__repr__ [self] - (str [(python/id block) relative-to offset]))) + (str [:indent (python/id block) relative-to offset]))) (deftype Newline [block kind start end] (__repr__ [self] @@ -284,7 +284,7 @@ max-col (:max @writer)] (and miser-width max-col - (>= (.-start-col (.-block token)) (- max miser-width)) + (>= (.-start-col (.-block token)) (- max-col miser-width)) (emit-linear-nl? token section))) ;; TODO: figure out how to handle these newline types :fill nil)) diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index fbc621de5..ee40574a3 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -283,6 +283,41 @@ 28 29)"] (match-ideref v)))))) +(defmulti miser-dispatch type) + +(defmethod miser-dispatch :default + [o] + (pr o)) + +(defmethod miser-dispatch basilisp.lang.interfaces/IPersistentVector + [o] + (pprint/pprint-logical-block :prefix "[" :suffix "]" + (pprint/print-length-loop [binding o] + (when (seq binding) + (pprint/pprint-logical-block + (pprint/write-out (first binding)) + (when (next binding) + (.write *out* " ") + (pprint/pprint-newline :miser) + (pprint/write-out (second binding)))) + (when-let [remaining (next (rest binding))] + (.write *out* " ") + (pprint/pprint-newline :linear) + (recur remaining)))))) + +(deftest pprint-miser-test + (binding [pprint/*print-pprint-dispatch* miser-dispatch] + (are [res margin] (= res (str/rtrim + (binding [pprint/*print-right-margin* margin] + (with-out-str + (pprint/pprint [:abcdefghijklmnop [:abcdefghijklmn :a]]))))) + "[:abcdefghijklmnop + [:abcdefghijklmn + :a]]" 20 + "[:abcdefghijklmnop + [:abcdefghijklmn :a]]" 25 + "[:abcdefghijklmnop [:abcdefghijklmn :a]]" 50))) + (deftest pprint-print-level-test (are [res plen expr] (= res (str/rtrim (binding [*print-level* plen] From 26cb6474bf2814a4d2934e917fdfec37ad3bf9b4 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Thu, 5 Jun 2025 20:06:26 -0400 Subject: [PATCH 20/29] Records --- src/basilisp/pprint.lpy | 8 ++++++++ tests/basilisp/test_pprint.lpy | 8 ++++++++ 2 files changed, 16 insertions(+) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 369d0fb44..7704789f3 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -673,6 +673,14 @@ (print-meta obj) (print-map "{" "}" obj)) +(defmethod simple-dispatch basilisp.lang.interfaces/IRecord + [obj] + (print-meta obj) + (let [prefix (str "#" (.-__qualname__ (python/type obj)) "{")] + (print-map prefix "}" (into {} obj)))) + +(prefer-method simple-dispatch basilisp.lang.interfaces/IRecord basilisp.lang.interfaces/IPersistentMap) + (defmethod simple-dispatch python/dict [obj] (print-map "#py {" "}" (.items obj))) diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index ee40574a3..2e778bcae 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -216,6 +216,14 @@ (deftest pprint-var-test (is (= "#'basilisp.core/map\n" (with-out-str (pprint/pprint #'map))))) +(defrecord Point [x y z]) + +(deftest pprint-record-test + (is (= "#Point{:x 1 :y 2 :z 3}\n" + (with-out-str + (binding [pprint/*print-sort-keys* true] + (pprint/pprint (->Point 1 2 3))))))) + (deftest pprint-ideref-test (testing "delay" (let [d (delay :delayed)] From a1b31a5faf0cb54ec0e483869730f7f5f85169e4 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Fri, 6 Jun 2025 19:41:10 -0400 Subject: [PATCH 21/29] Fix PyPy, reformat, update documentation --- docs/api/pprint.rst | 3 +- src/basilisp/pprint.lpy | 342 ++++++++++++++++++++++++++++------------ 2 files changed, 240 insertions(+), 105 deletions(-) diff --git a/docs/api/pprint.rst b/docs/api/pprint.rst index 24f59802f..806127d44 100644 --- a/docs/api/pprint.rst +++ b/docs/api/pprint.rst @@ -7,4 +7,5 @@ basilisp.pprint .. autonamespace:: basilisp.pprint :members: - :undoc-members: \ No newline at end of file + :undoc-members: + :exclude-members: LogicalBlock, StartBlock, EndBlock, Blob, Newline, Indent, *current-length*, *current-level* \ No newline at end of file diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 7704789f3..de83ef9d8 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -1,8 +1,58 @@ (ns basilisp.pprint - "Basilisp pretty printing functionality. + "Basilisp pretty printer - References: - - Tom Faulhaber; `clojure.pprint` + Pretty Printing + --------------- + + Pretty printing built-in data structures is as easy as a call to :lpy:fn:`pprint`. + + .. code-block:: + + (require '[basilisp.pprint :as pprint]) + (pprint/pprint (range 30)) + + The output can be configured using a number of different control variables, which + are expressed as dynamic Vars. + + - :lpy:fn:`*print-base*` + - :lpy:fn:`*print-miser-width*` + - :lpy:fn:`*print-pprint-dispatch*` + - :lpy:fn:`*print-radix*` + - :lpy:fn:`*print-right-margin*` + - :lpy:fn:`*print-sort-keys*` + - :lpy:fn:`*print-suppress-namespaces*` + + You can pretty print the last result from the REPL using the :lpy:fn:`pp` convenience + macro. + + As an alternative, the :lpy:fn:`write` API enables a more ergonomic API for + configuring the printer using keyword arguments rather than dynamic Vars. + + .. code-block:: + + (pprint/write (ns-interns 'basilisp.pprint) :sort-keys true) + ;; {*current-length* #'basilisp.pprint/*current-length* + ;; ... + ;; write-out #'basilisp.pprint/write-out} + + Custom Pretty Print Dispatch Function + ------------------------------------- + + TBD + + Unimplemented Features + ---------------------- + + The following features from ``clojure.pprint`` are not currently implemented: + + - ``:fill`` newlines + - ``code-dispatch`` for printing code + - ``cl-format`` + + References + ---------- + + - Tom Faulhaber et al.; ``clojure.pprint`` - Oppen, Derek; \"Prettyprinting\"; October 1980 - Waters, Richard; \"XP: A Common Lisp Pretty Printing System\"; March 1989" (:require @@ -11,12 +61,10 @@ (:import fractions io os + platform threading)) -;; TODO: -;; - fill newlines - -(declare simple-dispatch code-dispatch write-out) +(declare simple-dispatch write-out) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Dynamic Vars for Configuration ;; @@ -64,7 +112,9 @@ 72) (def ^{:doc "If bound to ``true``, associative collections will be printed in sorted - order by their keys. Default is ``false``." + order by their keys. + + Default is ``false``." :dynamic true} *print-sort-keys* false) @@ -113,27 +163,27 @@ basilisp.lang.interfaces/IDeref (deref [self] (with [_ lock] - @state)) + @state)) ^:abstract ^{:abstract-members #{:flush :write}} io/TextIOBase (write [self s] (with [_ lock] - (let [[init final] (.rsplit s os/linesep 1)] - (vswap! state - (fn [{:keys [col line] :as old-state}] - (if final - (let [nlines (count (.splitlines init))] - (-> old-state - (assoc :col (count final)) - (assoc :line (+ line nlines)))) - (update old-state :col + (count init)))))) + (let [[init final] (.rsplit s os/linesep 1)] + (vswap! state + (fn [{:keys [col line] :as old-state}] + (if final + (let [nlines (count (.splitlines init))] + (-> old-state + (assoc :col (count final)) + (assoc :line (+ line nlines)))) + (update old-state :col + (count init)))))) (.write writer s))) (flush [self] (with [_ lock] - (.flush writer))) + (.flush writer))) (__repr__ [self] (str "")))))) @@ -144,27 +194,27 @@ ;; `indent` may be changed later by an indent token, whereas `start-col` is fixed at ;; the point the start block token is encountered in the stream. -(deftype LogicalBlock [parent prefix per-line-prefix suffix ^:mutable indent ^:mutable start-col ^:mutable force-nl?] +(deftype ^:private LogicalBlock [parent prefix per-line-prefix suffix ^:mutable indent ^:mutable start-col ^:mutable force-nl?] (__repr__ [self] (str [(python/id self) (python/repr parent) prefix suffix indent force-nl?]))) -(deftype StartBlock [block start end] +(deftype ^:private StartBlock [block start end] (__repr__ [self] (str [:start (python/id block)]))) -(deftype EndBlock [block start end] +(deftype ^:private EndBlock [block start end] (__repr__ [self] (str [:end (python/id block)]))) -(deftype Blob [data start end] +(deftype ^:private Blob [data start end] (__repr__ [self] data)) -(deftype Indent [block relative-to offset start end] +(deftype ^:private Indent [block relative-to offset start end] (__repr__ [self] (str [:indent (python/id block) relative-to offset]))) -(deftype Newline [block kind start end] +(deftype ^:private Newline [block kind start end] (__repr__ [self] (str [kind (python/id block)]))) @@ -228,15 +278,23 @@ (split-queue-with comparator (pop buffer)))) (defprotocol PrettyWriter + "Protocol defining a writer type for pretty printing with the XP algorithm." (start-block [this prefix per-line-prefix suffix]) (end-block [this]) (pp-indent [this relative-to offset]) (pp-newline [this kind])) (defn get-pretty-writer - "Return a pretty writer instance, which is also an :external:py:class:`io.TextIOBase`. + "Return a pretty writer instance which satisfies :lpy:proto:`PrettyWriter` and which + is also an :external:py:class:`io.TextIOBase`. - The current state can be fetched using :lpy:fn:`basilisp.core/deref`." + The current state can be fetched using :lpy:fn:`basilisp.core/deref`. + + .. warning: + + When using the pretty writer returned by ``get-pretty-writer`` on PyPy, be sure to + call ``(.flush ...)`` on the writer before returning, otherwise the buffer may not + be flushed until a later time." ([writer] (get-pretty-writer writer *print-right-margin*)) ([writer max-columns] @@ -371,64 +429,65 @@ (^:mutable reify basilisp.lang.interfaces/IDeref (deref [self] - (with [_ lock] - @state)) + (with [_ lock] + @state)) ^:abstract ^{:abstract-members #{:flush :write}} io/TextIOBase (write [self s] - (with [_ lock] - (if-not (seq (:buffer @state)) - (.write writer s) - (do - (let [[old-pos new-pos] (update-pos s) - blob (Blob s old-pos new-pos)] - (add-to-buffer blob)))) - (count s))) + (with [_ lock] + (if-not (seq (:buffer @state)) + (.write writer s) + (do + (let [[old-pos new-pos] (update-pos s) + blob (Blob s old-pos new-pos)] + (add-to-buffer blob)))) + (count s))) (flush [self] - (with [_ lock] - (when-let [buf (:buffer @state)] - (write-tokens buf)) - (.flush writer))) + (with [_ lock] + (when-let [buf (:buffer @state)] + (write-tokens buf) + (vswap! state #(assoc % :buffer (queue)))) + (.flush writer))) PrettyWriter (start-block [self prefix per-line-prefix suffix] - (with [_ lock] - (let [current-block (:block @state) - new-block (LogicalBlock current-block prefix per-line-prefix suffix 0 0 false) - [old-pos new-pos] (update-pos prefix) - start-block (StartBlock new-block old-pos new-pos)] - (vswap! state #(-> % - (assoc :block new-block) - (assoc :pos new-pos))) - (add-to-buffer start-block))) - nil) + (with [_ lock] + (let [current-block (:block @state) + new-block (LogicalBlock current-block prefix per-line-prefix suffix 0 0 false) + [old-pos new-pos] (update-pos prefix) + start-block (StartBlock new-block old-pos new-pos)] + (vswap! state #(-> % + (assoc :block new-block) + (assoc :pos new-pos))) + (add-to-buffer start-block))) + nil) (end-block [self] - (with [_ lock] - (let [{:keys [block pos]} @state - suffix (.-suffix block) - [old-pos new-pos] (update-pos suffix) - end-block (EndBlock block pos new-pos)] - (vswap! state #(assoc % :block (.-parent block))) - (add-to-buffer end-block))) - nil) + (with [_ lock] + (let [{:keys [block pos]} @state + suffix (.-suffix block) + [old-pos new-pos] (update-pos suffix) + end-block (EndBlock block pos new-pos)] + (vswap! state #(assoc % :block (.-parent block))) + (add-to-buffer end-block))) + nil) (pp-indent [self relative-to offset] - (with [_ lock] - (let [{:keys [block pos]} @state - indent (Indent block relative-to offset pos pos)] - (add-to-buffer indent))) - nil) + (with [_ lock] + (let [{:keys [block pos]} @state + indent (Indent block relative-to offset pos pos)] + (add-to-buffer indent))) + nil) (pp-newline [self kind] - (with [_ lock] - (let [{:keys [block pos]} @state - nl (Newline block kind pos pos)] - (add-to-buffer nl))) - nil)))))) + (with [_ lock] + (let [{:keys [block pos]} @state + nl (Newline block kind pos pos)] + (add-to-buffer nl))) + nil)))))) ;;;;;;;;;;;;; ;; Helpers ;; @@ -471,10 +530,11 @@ (.write *out* "..."))))) (defn pprint-indent - "Configure the indent of `offset` characters relative to an anchor at this point + "Configure the indent of ``offset`` characters relative to an anchor at this point in the pretty print output. ``relative-to`` must be one of the following keywords: + - ``:current``, meaning that the indent offset is relative to the current column when the indent token is encountered - ``:block``, meaning that the indent offset is relative to the starting column of @@ -490,18 +550,35 @@ "Emit a newline to the output buffer. ``kind`` must be one of the following keywords: + - ``:linear``, which will be emitted as newlines only if the the logical block doesn't fit on one line - ``:mandatory``, which the pretty writer will emit in all cases - - ``:miser`` - - ``:fill``" + - ``:miser``, which will emit a newline whenever the output column is in the + miser region, as configured by :lpy:var:`*print-miser-width*`" [kind] - (when-not (#{:linear :mandatory :miser :fill} kind) + (when-not (#{:linear :mandatory :miser} kind) (throw - (ex-info "Newline must be one of: :linear, :mandatory, :miser, :fill" + (ex-info "Newline must be one of: :linear, :mandatory, :miser" {:kind kind}))) (pp-newline *out* kind)) +(defmacro ^:private with-pretty-writer + "Flush the pretty printer on PyPy before exiting. + + The writer returned from :lpy:fn:`get-pretty-writer` does not seem to flush + correctly when a newline is encountered on PyPy, so this just forces a flush + after printing to ensure the full output is written." + [bindings & body] + (let [[binding writer] bindings] + `(let [~binding (get-pretty-writer ~writer)] + ~(if (not= "PyPy" (platform/python-implementation)) + `(do ~@body) + `(try + ~@body + (finally + (.flush ~binding))))))) + ;;;;;;;;;;;;;;;;;;;;; ;; Simple Dispatch ;; ;;;;;;;;;;;;;;;;;;;;; @@ -587,13 +664,13 @@ "Print a non-associative collection with the given prefix and suffix strings." [prefix suffix coll] (pprint-logical-block :prefix prefix :suffix suffix - (print-length-loop [v coll] - (when (seq v) - (write-out (first v)) - (when-let [more (seq (rest v))] - (.write *out* " ") - (pprint-newline :linear) - (recur more)))))) + (print-length-loop [v coll] + (when (seq v) + (write-out (first v)) + (when-let [more (seq (rest v))] + (.write *out* " ") + (pprint-newline :linear) + (recur more)))))) (defn ^:private print-map "Print an associative collection." @@ -602,21 +679,21 @@ (sort-by key obj) obj)] (pprint-logical-block :prefix prefix :suffix suffix - (print-length-loop [m coll] - (when (seq m) - (let [[k v] (first m)] - (pprint-logical-block - (write-out k) - (.write *out* " ") - (pprint-newline :linear) - ;; set the current length such that we won't print - ;; only a key without it's corresponding value - (binding [*current-length* (dec *current-length*)] - (write-out v))) - (when-let [more (seq (rest m))] - (.write *out* " ") - (pprint-newline :linear) - (recur more)))))))) + (print-length-loop [m coll] + (when (seq m) + (let [[k v] (first m)] + (pprint-logical-block + (write-out k) + (.write *out* " ") + (pprint-newline :linear) + ;; set the current length such that we won't print + ;; only a key without it's corresponding value + (binding [*current-length* (dec *current-length*)] + (write-out v))) + (when-let [more (seq (rest m))] + (.write *out* " ") + (pprint-newline :linear) + (recur more)))))))) (defn ^:private print-meta "Print the metadata associated with an object if it has any metadata and if @@ -702,9 +779,9 @@ (not (realized? obj))) :not-delivered :else @obj)] (pprint-logical-block :prefix prefix :suffix ">" - (pprint-indent :block (- (- (count prefix) 2))) - (pprint-newline :linear) - (write-out contents)))) + (pprint-indent :block (- (- (count prefix) 2))) + (pprint-newline :linear) + (write-out contents)))) (alter-var-root #'*print-pprint-dispatch* (constantly simple-dispatch)) @@ -712,6 +789,21 @@ ;; Pretty Printing Public API ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defn set-pprint-dispatch + "Set the root value of :lpy:fn:`*print-pprint-dispatch*` to ``function``. + + By default, the root value is :lpy:var:`simple-dispatch`." + [function] + (alter-var-root #'*print-pprint-dispatch* (constantly function)) + nil) + +(defmacro with-pprint-dispatch + "Convenience macro for setting the :lpy:var:`*print-pprint-dispatch*` while executing + the body." + [function & body] + `(binding [*print-pprint-dispatch* ~function] + ~@body)) + ;; Calls to `write-out` will add object IDs (per `python/id`) to the `*recursion-context*` ;; and check that context on recursive calls, allowing for cycle detection in pretty ;; printed output. @@ -748,17 +840,59 @@ (pr object))) (defn pprint - "Pretty print ``object`` to the given ``writer``. + "Pretty print ``object`` to the ``writer`` subject to the bindings of the pretty + printing control variables. If no ``writer`` is given, the value bound to :lpy:var:`basilisp.core/*out*` is used." ([object] (pprint object *out*)) ([object writer] - (binding [*out* (get-pretty-writer writer) - *print-pretty* true] - (write-out object) - (newline)))) + (with-pretty-writer [writer writer] + (binding [*out* writer + *print-pretty* true] + (write-out object) + (newline))))) + +(def ^:private write-control-map + {:base #'*print-base* + :dispatch #'*print-pprint-dispatch* + :length #'*print-length* + :level #'*print-level* + :miser-width #'*print-miser-width* + :pretty #'*print-pretty* + :radix #'*print-radix* + :right-margin #'*print-right-margin* + :sort-keys #'*print-sort-keys* + :suppress-namespaces #'*print-suppress-namespaces*}) + +(defn write + "Pretty print ``object`` as by :lpy:fn:`pprint`, but options may be specified + as keyword arguments rather than dynamic Vars. + + The supported keyword arguments are listed below with their corresponding dynamic + Var: + + - ``:base`` corresponds to :lpy:var:`*print-base*` + - ``:dispatch`` corresponds to :lpy:var:`*print-pprint-dispach*` + - ``:length`` corresponds to :lpy:var:`basilisp.core/*print-length*` + - ``:level`` corresponds to :lpy:var:`basilisp.core/*print-level*` + - ``:pretty`` corresponds to :lpy:var:`*print-pretty*` + - ``:radix`` corresponds to :lpy:var:`*print-radix*` + - ``:miser-width`` corresponds to :lpy:var:`*print-miser-width*` + - ``:right-margin`` corresponds to :lpy:var:`*print-right-margin*` + - ``:sort-keys`` corresponds to :lpy:var:`*print-sort-keys` + - ``:stream`` corresponds to the ``writer`` argument of :lpy:fn:`pprint` + - ``:suppress-namespaces`` corresponds to :lpy:var:`*print-suppress-namespaces*`" + [object & {:as opts}] + (let [opts-bindings (into {} + (comp (map (fn [[k v]] + (when-let [vvar (get write-control-map k)] + [vvar v]))) + (filter identity)) + opts) + writer (get opts :stream *out*)] + (with-bindings* opts-bindings pprint object writer))) (defn pp "Print the last thing output to the REPL. From b96a880e3d5d2dc341f3273f8a54cad4484c01d1 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Fri, 6 Jun 2025 20:44:21 -0400 Subject: [PATCH 22/29] Test replace \r\n with \n --- tests/basilisp/test_pprint.lpy | 61 ++++++++++++++++++++++------------ 1 file changed, 39 insertions(+), 22 deletions(-) diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index 2e778bcae..cb69c7b7d 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -7,6 +7,11 @@ os textwrap)) +(defn trim-and-replace-newlines + [s] + (-> (str/trim s) + (str/replace "\n" os/linesep))) + (deftest column-writer-test (let [write (fn [s] (with [buf (io/StringIO)] @@ -14,13 +19,15 @@ (.write writer s) (select-keys @writer [:col :line]))) )] (is (= {:line 0 :col 5} (write "hello"))) - (is (= {:line 1 :col 15} (write "hello\nthere my friend"))) - (is (= {:line 2 :col 0} (write "hello\nthere my friend\n"))) + (is (= {:line 1 :col 15} (write (str "hello" os/linesep "there my friend")))) + (is (= {:line 2 :col 0} (write (str "hello" os/linesep "there my friend" os/linesep)))) (is (= {:line 0 :col 0} (write ""))))) (deftest pprint-test (testing "scalars" - (are [res expr] (= res (str/rtrim (with-out-str (pprint/pprint expr)))) + (are [res expr] (= res (trim-and-replace-newlines + (with-out-str + (pprint/pprint expr)))) "nil" nil "true" true "false" false @@ -41,7 +48,9 @@ "long.ns/sym" 'long.ns/sym)) (testing "collections" - (are [res expr] (= res (str/rtrim (with-out-str (pprint/pprint expr)))) + (are [res expr] (= res (trim-and-replace-newlines + (with-out-str + (pprint/pprint expr)))) "{}" {} "{:a 1}" {:a 1} @@ -64,7 +73,9 @@ "#{:a}" #{:a})) (testing "python collections" - (are [res expr] (= res (str/rtrim (with-out-str (pprint/pprint expr)))) + (are [res expr] (= res (trim-and-replace-newlines + (with-out-str + (pprint/pprint expr)))) "#py {}" (python/dict) "#py {:a 1}" (python/dict {:a 1}) @@ -80,7 +91,9 @@ "#py #{:a}" (python/set [:a]))) (testing "large collections" - (are [res expr] (= res (str/rtrim (with-out-str (pprint/pprint expr)))) + (are [res expr] (= res (trim-and-replace-newlines + (with-out-str + (pprint/pprint expr)))) "[(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) (21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39) :a @@ -135,7 +148,7 @@ ["abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc"]))))) (testing "printing meta" - (are [res expr] (= res (str/rtrim + (are [res expr] (= res (trim-and-replace-newlines (binding [*print-meta* true] (with-out-str (pprint/pprint expr))))) "[]" [] @@ -158,7 +171,7 @@ (let [long-map (into {} (map #(vector (keyword (python/chr %1)) %2) (range (python/ord "a") (python/ord "z")) (range)))] - (are [res len expr] (= res (str/rtrim + (are [res len expr] (= res (trim-and-replace-newlines (binding [pprint/*print-sort-keys* true *print-length* len] (with-out-str @@ -183,7 +196,7 @@ ...}" 15 long-map))) (deftest pprint-base-and-radix-test - (are [res base expr] (= res (str/rtrim + (are [res base expr] (= res (trim-and-replace-newlines (binding [pprint/*print-radix* true pprint/*print-base* base] (with-out-str @@ -208,21 +221,25 @@ "#18r1" 18 1 "#18r27" 18 43)) -(defn ^:private match-ideref - [v] - (let [s (with-out-str (pprint/pprint v))] - (drop 1 (re-matches #"#<(\w+)@0x[0-9a-f]+: ([^>]+)>\r?\n" s)))) - (deftest pprint-var-test - (is (= "#'basilisp.core/map\n" (with-out-str (pprint/pprint #'map))))) + (is (= "#'basilisp.core/map" + (str/rtrim + (with-out-str + (pprint/pprint #'map)))))) (defrecord Point [x y z]) (deftest pprint-record-test - (is (= "#Point{:x 1 :y 2 :z 3}\n" - (with-out-str - (binding [pprint/*print-sort-keys* true] - (pprint/pprint (->Point 1 2 3))))))) + (is (= "#Point{:x 1 :y 2 :z 3}" + (str/rtrim + (with-out-str + (binding [pprint/*print-sort-keys* true] + (pprint/pprint (->Point 1 2 3)))))))) + +(defn ^:private match-ideref + [v] + (let [s (trim-and-replace-newlines (with-out-str (pprint/pprint v)))] + (drop 1 (re-matches #"#<(\w+)@0x[0-9a-f]+: ([^>]+)>" s)))) (deftest pprint-ideref-test (testing "delay" @@ -315,7 +332,7 @@ (deftest pprint-miser-test (binding [pprint/*print-pprint-dispatch* miser-dispatch] - (are [res margin] (= res (str/rtrim + (are [res margin] (= res (trim-and-replace-newlines (binding [pprint/*print-right-margin* margin] (with-out-str (pprint/pprint [:abcdefghijklmnop [:abcdefghijklmn :a]]))))) @@ -327,7 +344,7 @@ "[:abcdefghijklmnop [:abcdefghijklmn :a]]" 50))) (deftest pprint-print-level-test - (are [res plen expr] (= res (str/rtrim + (are [res plen expr] (= res (trim-and-replace-newlines (binding [*print-level* plen] (with-out-str (pprint/pprint expr))))) @@ -337,7 +354,7 @@ "[[:a :b :c] [#]]" 2 [[:a :b :c] [[]]])) (deftest pprint-print-length-test - (are [res plen expr] (= res (str/rtrim + (are [res plen expr] (= res (trim-and-replace-newlines (binding [*print-length* plen] (with-out-str (pprint/pprint expr))))) From 39bfdd9f7af4f90846e4eb0ed38cb303e474fc56 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Fri, 6 Jun 2025 21:03:41 -0400 Subject: [PATCH 23/29] Do better --- src/basilisp/pprint.lpy | 1 + tests/basilisp/test_pprint.lpy | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index de83ef9d8..e8902a59b 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -16,6 +16,7 @@ - :lpy:fn:`*print-base*` - :lpy:fn:`*print-miser-width*` + - :lpy:fn:`*print-pretty*` - :lpy:fn:`*print-pprint-dispatch*` - :lpy:fn:`*print-radix*` - :lpy:fn:`*print-right-margin*` diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index cb69c7b7d..94a754cc3 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -10,7 +10,7 @@ (defn trim-and-replace-newlines [s] (-> (str/trim s) - (str/replace "\n" os/linesep))) + (str/replace "\r\n" "\n"))) (deftest column-writer-test (let [write (fn [s] From 110909df2854ba47f6082bf15b7a0605c8b71482 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Fri, 6 Jun 2025 21:23:12 -0400 Subject: [PATCH 24/29] Move location --- docs/api/pprint.rst | 59 +++++++++++++++++++++++++++++++++++++++++ src/basilisp/pprint.lpy | 57 --------------------------------------- 2 files changed, 59 insertions(+), 57 deletions(-) diff --git a/docs/api/pprint.rst b/docs/api/pprint.rst index 806127d44..f9c2744a0 100644 --- a/docs/api/pprint.rst +++ b/docs/api/pprint.rst @@ -5,6 +5,65 @@ basilisp.pprint :maxdepth: 2 :caption: Contents: +Pretty Printing +--------------- + +Pretty printing built-in data structures is as easy as a call to :lpy:fn:`pprint`. + +.. code-block:: + + (require '[basilisp.pprint :as pprint]) + (pprint/pprint (range 30)) + +The output can be configured using a number of different control variables, which +are expressed as dynamic Vars. + +- :lpy:var:`*print-base*` +- :lpy:var:`*print-miser-width*` +- :lpy:var:`*print-pretty*` +- :lpy:var:`*print-pprint-dispatch*` +- :lpy:var:`*print-radix*` +- :lpy:var:`*print-right-margin*` +- :lpy:var:`*print-sort-keys*` +- :lpy:var:`*print-suppress-namespaces*` + +You can pretty print the last result from the REPL using the :lpy:fn:`pp` convenience +macro. + +As an alternative, the :lpy:fn:`write` API enables a more ergonomic API for +configuring the printer using keyword arguments rather than dynamic Vars. + +.. code-block:: + + (pprint/write (ns-interns 'basilisp.pprint) :sort-keys true) + ;; {*current-length* #'basilisp.pprint/*current-length* + ;; ... + ;; write-out #'basilisp.pprint/write-out} + +Custom Pretty Print Dispatch Function +------------------------------------- + +TBD + +Unimplemented Features +---------------------- + +The following features from ``clojure.pprint`` are not currently implemented: + +- ``:fill`` newlines +- ``code-dispatch`` for printing code +- ``cl-format`` + +References +---------- + +- Tom Faulhaber et al.; ``clojure.pprint`` +- Oppen, Derek; \"Prettyprinting\"; October 1980 +- Waters, Richard; \"XP: A Common Lisp Pretty Printing System\"; March 1989 + +API +--- + .. autonamespace:: basilisp.pprint :members: :undoc-members: diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index e8902a59b..22d97b5ee 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -1,61 +1,4 @@ (ns basilisp.pprint - "Basilisp pretty printer - - Pretty Printing - --------------- - - Pretty printing built-in data structures is as easy as a call to :lpy:fn:`pprint`. - - .. code-block:: - - (require '[basilisp.pprint :as pprint]) - (pprint/pprint (range 30)) - - The output can be configured using a number of different control variables, which - are expressed as dynamic Vars. - - - :lpy:fn:`*print-base*` - - :lpy:fn:`*print-miser-width*` - - :lpy:fn:`*print-pretty*` - - :lpy:fn:`*print-pprint-dispatch*` - - :lpy:fn:`*print-radix*` - - :lpy:fn:`*print-right-margin*` - - :lpy:fn:`*print-sort-keys*` - - :lpy:fn:`*print-suppress-namespaces*` - - You can pretty print the last result from the REPL using the :lpy:fn:`pp` convenience - macro. - - As an alternative, the :lpy:fn:`write` API enables a more ergonomic API for - configuring the printer using keyword arguments rather than dynamic Vars. - - .. code-block:: - - (pprint/write (ns-interns 'basilisp.pprint) :sort-keys true) - ;; {*current-length* #'basilisp.pprint/*current-length* - ;; ... - ;; write-out #'basilisp.pprint/write-out} - - Custom Pretty Print Dispatch Function - ------------------------------------- - - TBD - - Unimplemented Features - ---------------------- - - The following features from ``clojure.pprint`` are not currently implemented: - - - ``:fill`` newlines - - ``code-dispatch`` for printing code - - ``cl-format`` - - References - ---------- - - - Tom Faulhaber et al.; ``clojure.pprint`` - - Oppen, Derek; \"Prettyprinting\"; October 1980 - - Waters, Richard; \"XP: A Common Lisp Pretty Printing System\"; March 1989" (:require [basilisp.string :as str] [basilisp.walk :as walk]) From 2dbec9bf35dc6f40673b0a104c5ccef68a3f5886 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Fri, 6 Jun 2025 21:31:56 -0400 Subject: [PATCH 25/29] Newline --- tests/basilisp/test_pprint.lpy | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/basilisp/test_pprint.lpy b/tests/basilisp/test_pprint.lpy index 94a754cc3..1c31e39e2 100644 --- a/tests/basilisp/test_pprint.lpy +++ b/tests/basilisp/test_pprint.lpy @@ -142,7 +142,7 @@ (vector (range 20) (range 21 40) :a :b :c (range 41 80) (range 81 100)))) (testing "printing collections with long elements" - (is (= "[\"abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc\"]\n" + (is (= (str "[\"abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc\"]" os/linesep) (with-out-str (pprint/pprint ["abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc"]))))) From 34aea380f01bad5287ec20b19f191f8344f306d3 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Sat, 7 Jun 2025 14:51:24 -0400 Subject: [PATCH 26/29] Fix some things --- src/basilisp/core.lpy | 2 +- src/basilisp/pprint.lpy | 27 ++++++++++++++++++++------- tests/basilisp/test_core_fns.lpy | 1 + 3 files changed, 22 insertions(+), 8 deletions(-) diff --git a/src/basilisp/core.lpy b/src/basilisp/core.lpy index b84ea1522..cdc0b830b 100644 --- a/src/basilisp/core.lpy +++ b/src/basilisp/core.lpy @@ -2589,7 +2589,7 @@ ([] (iterate inc 0)) ([end] - (lazy-seq (cons 0 (range 1 end)))) + (range 0 end)) ([start end] (lazy-seq (when (< start end) diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index 22d97b5ee..c363002a9 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -14,7 +14,9 @@ ;; Dynamic Vars for Configuration ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(def ^{:doc "The base used for printing integer literals and rationals. Default is 10." +(def ^{:doc "The base used for printing integer literals and rationals. + + Default is 10." :dynamic true} *print-base* 10) @@ -37,6 +39,7 @@ nil) (def ^{:doc "If bound to ``true``, calls to :lpy:fn:`write` will use pretty printing. + Default is ``false``, but :lpy:fn:`pprint` binds the value to ``true``." :dynamic true} *print-pretty* @@ -45,12 +48,16 @@ (def ^{:doc "If bound to ``true``, integers and rationals will be printed with a radix prefix. For bases 2, 8, and 16 the prefix will be ``#b``, ``#o`` and ``#x`` respectively. All other bases will be specified as ``#XXr`` where ``XX`` is - the decimal value of :lpy:var:`*print-base*`." + the decimal value of :lpy:var:`*print-base*`. + + Default is ``false``." :dynamic true} *print-radix* false) -(def ^{:doc "The soft upper limit for the length of the right margin. Default is 72." +(def ^{:doc "The soft upper limit for the length of the right margin. + + Default is 72." :dynamic true} *print-right-margin* 72) @@ -222,7 +229,15 @@ (split-queue-with comparator (pop buffer)))) (defprotocol PrettyWriter - "Protocol defining a writer type for pretty printing with the XP algorithm." + "Protocol defining a writer type for pretty printing with the XP algorithm. + + Callers should generally not be calling ``PrettyWriter`` protocol methods directly, + but should instead call the other helper functions and macros directly. + + .. seealso:: + + :lpy:fn:`pprint-logical-block`, :lpy:fn:`print-length-loop`, + :lpy:fn:`pprint-newline`, :lpy:fn:`pprint-indent`" (start-block [this prefix per-line-prefix suffix]) (end-block [this]) (pp-indent [this relative-to offset]) @@ -287,9 +302,7 @@ (and miser-width max-col (>= (.-start-col (.-block token)) (- max-col miser-width)) - (emit-linear-nl? token section))) - ;; TODO: figure out how to handle these newline types - :fill nil)) + (emit-linear-nl? token section))))) ;; Generate the newline and subsequent indent from a newline token token. (gen-nl [token] diff --git a/tests/basilisp/test_core_fns.lpy b/tests/basilisp/test_core_fns.lpy index 18538f6ac..904d0b1c3 100644 --- a/tests/basilisp/test_core_fns.lpy +++ b/tests/basilisp/test_core_fns.lpy @@ -808,6 +808,7 @@ (is (= '(0 1 2 3 4) (take 5 (range))))) (testing "1-arity" + (is (= '() (range 0))) (is (= '(0 1 2) (take 5 (range 3)))) (is (= '(0 1 2) (range 3))) (is (= '(0 1 2 3 4) (take 5 (range 10))))) From 530335d7592387e9eec85549271330722ee6037d Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Sat, 7 Jun 2025 15:31:48 -0400 Subject: [PATCH 27/29] Documentation --- docs/api/pprint.rst | 63 ++++++++++++++++++++++++++++++++++++----- docs/interfaces.rst | 2 +- src/basilisp/pprint.lpy | 4 +-- 3 files changed, 59 insertions(+), 10 deletions(-) diff --git a/docs/api/pprint.rst b/docs/api/pprint.rst index f9c2744a0..dbf734dd7 100644 --- a/docs/api/pprint.rst +++ b/docs/api/pprint.rst @@ -1,10 +1,14 @@ basilisp.pprint =============== +.. lpy:currentns:: basilisp.pprint + .. toctree:: :maxdepth: 2 :caption: Contents: +.. _pretty_printing: + Pretty Printing --------------- @@ -15,8 +19,7 @@ Pretty printing built-in data structures is as easy as a call to :lpy:fn:`pprint (require '[basilisp.pprint :as pprint]) (pprint/pprint (range 30)) -The output can be configured using a number of different control variables, which -are expressed as dynamic Vars. +The output can be configured using a number of different control variables, which are expressed as dynamic Vars. - :lpy:var:`*print-base*` - :lpy:var:`*print-miser-width*` @@ -27,11 +30,9 @@ are expressed as dynamic Vars. - :lpy:var:`*print-sort-keys*` - :lpy:var:`*print-suppress-namespaces*` -You can pretty print the last result from the REPL using the :lpy:fn:`pp` convenience -macro. +You can pretty print the last result from the REPL using the :lpy:fn:`pp` convenience macro. -As an alternative, the :lpy:fn:`write` API enables a more ergonomic API for -configuring the printer using keyword arguments rather than dynamic Vars. +As an alternative, the :lpy:fn:`write` API enables a more ergonomic API for configuring the printer using keyword arguments rather than dynamic Vars. .. code-block:: @@ -40,10 +41,54 @@ configuring the printer using keyword arguments rather than dynamic Vars. ;; ... ;; write-out #'basilisp.pprint/write-out} +.. _custom_pretty_print_dispatch_function: + Custom Pretty Print Dispatch Function ------------------------------------- -TBD +The default dispatch function is :lpy:fn:`simple-dispatch` which can print most builtin Basilisp types. +Using the builtin macros and utilities, it is possible to create a custom dispatch function. + +.. _pretty_printing_concepts: + +Pretty Printing Concepts +^^^^^^^^^^^^^^^^^^^^^^^^ + +The pretty printing algorithm used in ``basilisp.pprint`` is based on the XP algorithm defined in Richard Water's 1989 paper "XP: A Common Lisp Pretty Printing System" as adapted in Clojure's ``pprint`` by Tom Faulhaber. +There are three basic concepts in the XP algorithm which are necessary in order to create a custom dispatch function. + +- *Logical blocks* are groups of output that should be treated as a single unit by the pretty printer. + Logical blocks can nest, so one logical block may contain 0 or more other logical blocks. + For example, a vector may contain a map; the vector would be a logical block and the map would also be a logical block. + ``simple-dispatch`` even treats key/value pairs in associative type outputs as a logical block, so they are printed on the same line whenever possible. + + A dispatch function can emit a logical block using the :lpy:fn:`pprint-logical-block` macro. + +- *Conditional newlines* can be emitted anywhere a newline may need inserted into the output stream. + Newlines can be one of 3 different types which hints to the pretty printer when a newline should be emitted. + + Dispatch functions can emit newlines in any supported style using the :lpy:fn:`pprint-newline` function. + + - ``:linear`` style newlines should be emitted whenever the enclosing logical block does not fit on a single line. + Note that if any linear newline is emitted in a block, every linear newline will be emitted in that block. + + - ``:mandatory`` style newlines are emitted in all cases. + + - ``:miser`` style newlines are emitted only when the output will occur in the "miser" region as defined by :lpy:var:`*print-miser-width*`. + This allows additional newlines to be emitted as the output nests closer to the right margin. + +- *Indentation* commands indicate how indentation of subsequent lines in a logical block should be defined. + Indentation may be defined relative to either the starting column of the current logical block or to the current column of the output. + + Dispatch functions can control indentation using the :lpy:fn:`pprint-indent` function. + +Pretty printing is most useful for viewing large, nested structures in a more human-friendly way. +To that end, dispatch functions wishing to print any collection may want to use the :lpy:fn:`print-length-loop` macro to loop over the output, respecting the :lpy:var:`basilisp.core/*print-length*` setting. + +Dispatch functions which may need to be called on nested elements should use :lpy:fn:`write-out` to ensure that :lpy:var:`basilisp.core/*print-level*` is respected. +Scalar values can be printed with :lpy:fn:`basilisp.core/pr` or just written directly to :lpy:var:`*out*`. + +.. _unimplemented_pprint_features: Unimplemented Features ---------------------- @@ -54,6 +99,8 @@ The following features from ``clojure.pprint`` are not currently implemented: - ``code-dispatch`` for printing code - ``cl-format`` +.. _pprint_references: + References ---------- @@ -61,6 +108,8 @@ References - Oppen, Derek; \"Prettyprinting\"; October 1980 - Waters, Richard; \"XP: A Common Lisp Pretty Printing System\"; March 1989 +.. _pprint_api: + API --- diff --git a/docs/interfaces.rst b/docs/interfaces.rst index d6def10d7..333a22199 100644 --- a/docs/interfaces.rst +++ b/docs/interfaces.rst @@ -22,7 +22,7 @@ In day-to-day usage, you will not typically need to use these interfaces, but th .. automethod:: _lrepr .. automethod:: lrepr -.. lpy:currentns:: basilisp.core +.. lpy:currentns:: basilisp.core .. automodule:: basilisp.lang.interfaces :members: diff --git a/src/basilisp/pprint.lpy b/src/basilisp/pprint.lpy index c363002a9..7536c8769 100644 --- a/src/basilisp/pprint.lpy +++ b/src/basilisp/pprint.lpy @@ -236,8 +236,8 @@ .. seealso:: - :lpy:fn:`pprint-logical-block`, :lpy:fn:`print-length-loop`, - :lpy:fn:`pprint-newline`, :lpy:fn:`pprint-indent`" + :ref:`pretty_printing_concepts`, :lpy:fn:`pprint-logical-block`, + :lpy:fn:`print-length-loop`, :lpy:fn:`pprint-newline`, :lpy:fn:`pprint-indent`" (start-block [this prefix per-line-prefix suffix]) (end-block [this]) (pp-indent [this relative-to offset]) From eec0488c6f9dcd6511e59e8d525d03104f71b4eb Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Sat, 7 Jun 2025 15:34:45 -0400 Subject: [PATCH 28/29] Links --- docs/api/pprint.rst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docs/api/pprint.rst b/docs/api/pprint.rst index dbf734dd7..439d3cbc7 100644 --- a/docs/api/pprint.rst +++ b/docs/api/pprint.rst @@ -104,7 +104,7 @@ The following features from ``clojure.pprint`` are not currently implemented: References ---------- -- Tom Faulhaber et al.; ``clojure.pprint`` +- Tom Faulhaber et al.; ``clojure.pprint`` (`API `_, `Documentation `_) - Oppen, Derek; \"Prettyprinting\"; October 1980 - Waters, Richard; \"XP: A Common Lisp Pretty Printing System\"; March 1989 From 01fec1cfd3a2f12fb9413ef9175eed3a2359f095 Mon Sep 17 00:00:00 2001 From: Chris Rink Date: Sat, 7 Jun 2025 15:38:13 -0400 Subject: [PATCH 29/29] Changelog --- CHANGELOG.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e9ee49858..972aecfe9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,7 +16,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 * Added the `basilisp.pprint` namespace (#513) ### Changed - * Removed implicit support for single-use iterables in sequences, and introduced `iterator-seq` to expliciltly handle them (#1192) + * Removed implicit support for single-use iterables in sequences, and introduced `iterator-seq` to explicitly handle them (#1192) * `basilisp.core/str` now delegates to the builtin Python `str` in all cases except for customizing the string output for builtin Python types (#1237) * Optimised mainstream seq-consuming functions by coercing their inputs into `seq` upfront (#1234) * Renamed `awith` and `afor` to `with-async` and `for-async` for improved clarity (#1248) @@ -24,8 +24,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 * Updated support for PyPy to 3.9 and 3.10 (#1265) ### Fixed - * Fix a bug where protocols with methods with leading hyphens in the could not be defined (#1230) + * Fix a bug where protocols with methods with leading hyphens in method names could not be defined (#1230) * Fix a bug where attempting to `:refer` a non-existent Var from another namespace would throw an unhelpful exception (#1231) + * Fixed a bug where `(range 0)` would return `(0)` rather than than `()` as expected (#1258) ## [v0.3.8] ### Added