Skip to content

Commit 79a5560

Browse files
chrisrink10chrisrink10
committed
basilisp.pprint namespace
1 parent 97eab3e commit 79a5560

File tree

3 files changed

+442
-2
lines changed

3 files changed

+442
-2
lines changed

‎docs/differencesfromclojure.rst

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -225,6 +225,7 @@ Basilisp includes ports of some of the standard libraries from Clojure which sho
225225
* :lpy:ns:`basilisp.data` is a port of ``clojure.data``
226226
* :lpy:ns:`basilisp.edn` is a port of ``clojure.edn``
227227
* :lpy:ns:`basilisp.io` is a port of ``clojure.java.io``
228+
* :lpy:ns:`basilisp.pprint` is a port of ``clojure.pprint`` (excluding support for ``cl-format``)
228229
* :lpy:ns:`basilisp.set` is a port of ``clojure.set``
229230
* :lpy:ns:`basilisp.shell` is a port of ``clojure.java.shell``
230231
* :lpy:ns:`basilisp.stacktrace` is a port of ``clojure.stacktrace``

‎src/basilisp/pprint.lpy

Lines changed: 384 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,388 @@
11
(ns basilisp.pprint
2-
(:require [basilisp.string :as str]))
2+
(:require
3+
[basilisp.string :as str]
4+
[basilisp.walk :as walk])
5+
(:import fractions
6+
io
7+
os
8+
threading))
9+
10+
(declare simple-dispatch code-dispatch write-out)
11+
12+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13+
;; Dynamic Vars for Configuration ;;
14+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
15+
16+
(def ^{:doc "The base used for printing integer literals and rationals. Default is 10."
17+
:dynamic true}
18+
*print-base*
19+
10)
20+
21+
(def ^{:doc "The dispatch function used for pretty printing.
22+
23+
Default is :lpy:fn:`simple-dispatch`."
24+
:dynamic true}
25+
*print-pprint-dispatch*
26+
nil)
27+
28+
(def ^{:doc "If bound to ``true``, calls to :lpy:fn:`write` will use pretty printing.
29+
Default is ``false``, but :lpy:fn:`pprint` binds the value to ``true``."
30+
:dynamic true}
31+
*print-pretty*
32+
false)
33+
34+
(def ^{:doc "The soft upper limit for the length of the right margin. Default is 72."
35+
:dynamic true}
36+
*print-right-margin*
37+
72)
38+
39+
(def ^{:doc "If ``true``, suppress printing symbol namespaces. This may be useful when
40+
printing macroexpansions.
41+
42+
Default is ``nil``."
43+
:dynamic true}
44+
*print-suppress-namespaces*
45+
nil)
46+
47+
;;;;;;;;;;;;;;;;;;;
48+
;; Private State ;;
49+
;;;;;;;;;;;;;;;;;;;
50+
51+
(def ^:dynamic *current-level* 0)
52+
(def ^:dynamic *current-length* nil)
53+
54+
;;;;;;;;;;;;;;;;;;;
55+
;; Column Writer ;;
56+
;;;;;;;;;;;;;;;;;;;
57+
58+
(def ^:dynamic ^:private *default-page-width* 72)
59+
60+
(defn ^:private get-column-writer
61+
"Return an :external:py:class:`io.TextIOBase` instance which keeps track of the
62+
current line and column it has printed.
63+
64+
The ``max-columns`` input defaults to :lpy:var:`*default-page-width*`. This value
65+
is not used by the column writer, but may be introspected by callers.
66+
67+
The current state can be fetched using :lpy:fn:`basilisp.core/deref`."
68+
([writer]
69+
(get-column-writer writer *default-page-width*))
70+
([writer max-columns]
71+
(let [lock (threading/RLock)
72+
state (volatile! {:max max-columns :col 0 :line 0 :base writer})]
73+
(^:mutable reify
74+
basilisp.lang.interfaces/IDeref
75+
(deref [self]
76+
(with [_ lock]
77+
@state))
78+
79+
^:abstract
80+
^{:abstract-members #{:flush :write}}
81+
io/TextIOBase
82+
(write [self s]
83+
(with [_ lock]
84+
(let [[init final] (.rsplit s os/linesep 1)]
85+
(vswap! state
86+
(fn [{:keys [col line] :as old-state}]
87+
(if final
88+
(let [nlines (count (.splitlines init))]
89+
(-> old-state
90+
(assoc :col (count final))
91+
(assoc :line (+ line nlines))))
92+
(assoc old-state :col (count init))))))
93+
(.write writer s)))
94+
95+
(flush [self]
96+
(with [_ lock]
97+
(.flush writer)))
98+
99+
(__repr__ [self]
100+
(str "<ColumnWriter wrapping " (repr writer) ">"))))))
101+
102+
;;;;;;;;;;;
103+
;; Types ;;
104+
;;;;;;;;;;;
105+
106+
(defrecord LogicalBlock [parent prefix suffix indent])
107+
108+
(deftype StartBlock [block start end])
109+
110+
(deftype EndBlock [block start end])
111+
112+
(deftype Blob [data trailing-white-space start end])
113+
114+
(deftype Indent [block relative-to offset start end])
115+
116+
(deftype Newline [block kind start end])
117+
118+
;;;;;;;;;;;;;;;;;;;
119+
;; Pretty Writer ;;
120+
;;;;;;;;;;;;;;;;;;;
121+
122+
(defn ^:private buffer-length
123+
"Return the length of a given `PrettyWriter` buffer in characters."
124+
[buffer]
125+
(if-let [buf (seq buffer)]
126+
(- (.-end (last buf)) (.-start (first buf)))
127+
0))
128+
129+
(defprotocol PrettyWriter
130+
(start-block [this prefix suffix])
131+
(end-block [this])
132+
(pp-newline [this kind]))
133+
134+
(defn get-pretty-writer
135+
"Return a pretty writer instance, which is also an :external:py:class:`io.TextIOBase`.
136+
137+
The current state can be fetched using :lpy:fn:`basilisp.core/deref`."
138+
[writer]
139+
(let [lock (threading/RLock)
140+
writer (get-column-writer writer)
141+
state (volatile! {:base writer
142+
:block (->LogicalBlock nil nil nil 0)
143+
:buffer (queue)
144+
:pos 0
145+
:trailing-white-space nil})]
146+
(letfn [;; Private helpers can only be called while the lock is held
147+
(tokens-fit? [state tokens]
148+
(let [{:keys [base]} state
149+
{:keys [col max]} @base]
150+
(or (nil? max)
151+
(pos? (- max (+ col (buffer-length tokens)))))))
152+
153+
(write-line [state]
154+
(let [{:keys [buffer]} state]
155+
(assoc state :buffer
156+
(loop [{:keys [buffer]} state]
157+
nil))))
158+
159+
(add-to-buffer [state token]
160+
(let [{:keys [buffer] :as state} (update state :buffer conj token)]
161+
(if (not (tokens-fit? state buffer))
162+
(write-line state)
163+
state)))]
164+
(^:mutable reify
165+
basilisp.lang.interfaces/IDeref
166+
(deref [self]
167+
(with [_ lock]
168+
@state))
169+
170+
^:abstract
171+
^{:abstract-members #{:flush :write}}
172+
io/TextIOBase
173+
(write [self s]
174+
(with [_ lock]
175+
(if-not (seq (:buffer @state))
176+
(.write writer s)
177+
(do
178+
(vswap! state (fn [{:keys [pos] :as old-state}]
179+
(let [new-pos (+ pos (count s))
180+
blob (Blob s nil pos new-pos)]
181+
(-> old-state
182+
(assoc :pos new-pos)
183+
(add-to-buffer blob)))))))))
184+
185+
(flush [self]
186+
(with [_ lock]
187+
(.flush writer)))
188+
189+
PrettyWriter
190+
(start-block [self prefix suffix]
191+
(with [_ lock]
192+
(vswap! state (fn [{:keys [block base pos] :as old-state}]
193+
(let [indent (:col @base)
194+
new-block (LogicalBlock block
195+
prefix
196+
suffix
197+
indent)
198+
new-pos (if prefix
199+
(+ pos (count prefix))
200+
pos)
201+
start-block (StartBlock new-block pos new-pos)]
202+
(-> old-state
203+
(assoc :block new-block)
204+
(add-to-buffer start-block)
205+
(assoc :pos new-pos)))))))
206+
(end-block [self]
207+
(with [_ lock]
208+
(vswap! state (fn [{:keys [block pos] :as old-state}]
209+
(let [suffix (:suffix block)
210+
new-pos (if suffix
211+
(+ pos (count suffix))
212+
pos)
213+
end-block (EndBlock block pos new-pos)]
214+
(-> old-state
215+
(assoc :block (:parent block))
216+
(add-to-buffer end-block)))))))
217+
(pp-newline [self kind]
218+
(with [_ lock]
219+
(vswap! state (fn [{:keys [buffer block pos] :as old-state}]
220+
(->> (Newline block kind pos pos)
221+
(add-to-buffer old-state))))))))))
222+
223+
;;;;;;;;;;;;;
224+
;; Helpers ;;
225+
;;;;;;;;;;;;;
226+
227+
(defmacro pprint-logical-block
228+
[& body]
229+
(let [flag-names #{:prefix :per-line-prefix :suffix}
230+
[flags body] (loop [flags {}
231+
body body]
232+
(if (flag-names (first body))
233+
(recur (assoc flags (first body) (second body))
234+
(nthrest body 2))
235+
[flags body]))]
236+
`(with-bindings {#'*current-level* (inc *current-level*)}
237+
~(let [{:keys [prefix suffix]} flags]
238+
`(start-block *out* ~prefix ~suffix))
239+
~@body
240+
(end-block *out*))))
241+
242+
(defmacro print-length-loop
243+
":lpy:fn:`loop` -like macro which loops at most :lpy:fn:`basilisp.core/*print-length*`
244+
times, which is often useful when defining custom pretty-printing functions."
245+
[bindings & body]
246+
(let [len-sym (gensym "len")
247+
body (walk/postwalk
248+
(fn [form]
249+
(if (and (list? form) (= (first form) 'recur))
250+
(apply list 'recur `(inc ~len-sym) (rest form))
251+
form))
252+
body)]
253+
`(loop [~len-sym 0
254+
~@bindings]
255+
(if (or (not *print-length*) (< ~len-sym *print-length*))
256+
(do ~@body)
257+
(.write *out* "...")))))
258+
259+
(defn pprint-newline
260+
""
261+
[kind]
262+
(when-not (#{:linear :mandatory :miser :fill} kind)
263+
(throw
264+
(ex-info "Newline must be one of: :linear, :mandatory, :miser, :fill"
265+
{:kind kind})))
266+
(pp-newline *out* kind))
267+
268+
;;;;;;;;;;;;;;;;;;;;;
269+
;; Simple Dispatch ;;
270+
;;;;;;;;;;;;;;;;;;;;;
271+
272+
(defmulti simple-dispatch type)
273+
274+
(defmethod simple-dispatch :default
275+
[obj]
276+
(pr obj))
277+
278+
(defmethod simple-dispatch python/int
279+
[obj]
280+
(if-let [base (case *print-base*
281+
2 "{0:b}"
282+
8 "{0:o}"
283+
10 "{}"
284+
16 "{0:x}"
285+
nil)]
286+
(print (.format base obj))
287+
(throw
288+
(ex-info "Invalid integral base" {:base *print-base*}))))
289+
290+
;; This `python/bool` override is required because Python `bool` types are also
291+
;; instances of `python/int`, so they will be caught by the `int` dispatch otherwise.
292+
(defmethod simple-dispatch python/bool
293+
[obj]
294+
(pr obj))
295+
296+
(defmethod simple-dispatch fractions/Fraction
297+
[obj]
298+
(*print-pprint-dispatch* (numerator obj))
299+
(print "/")
300+
(*print-pprint-dispatch* (denominator obj)))
301+
302+
(defmethod simple-dispatch basilisp.lang.symbol/Symbol
303+
[obj]
304+
(if *print-suppress-namespaces*
305+
(print (name obj))
306+
(pr obj)))
307+
308+
(defn ^:private print-simple-coll
309+
"Print a non-associative collection with the given prefix and suffix strings."
310+
[prefix suffix coll]
311+
(pprint-logical-block :prefix prefix :suffix suffix
312+
(print-length-loop [v coll]
313+
(when (seq v)
314+
(write-out (first v))
315+
(when-let [more (seq (rest v))]
316+
(.write *out* " ")
317+
(recur more))))))
318+
319+
(defmethod simple-dispatch basilisp.lang.interfaces/ISeq
320+
[obj]
321+
(print-simple-coll "(" ")" obj))
322+
323+
(defmethod simple-dispatch basilisp.lang.interfaces/IPersistentList
324+
[obj]
325+
(print-simple-coll "(" ")" obj))
326+
327+
(defmethod simple-dispatch basilisp.lang.interfaces/IPersistentSet
328+
[obj]
329+
(print-simple-coll "#{" "}" obj))
330+
331+
(defmethod simple-dispatch basilisp.lang.interfaces/IPersistentVector
332+
[obj]
333+
(print-simple-coll "[" "]" obj))
334+
335+
(defmethod simple-dispatch basilisp.lang.interfaces/IPersistentMap
336+
[obj]
337+
(pprint-logical-block :prefix "{" :suffix "}"
338+
(print-length-loop [pair obj]
339+
(when-let [[k v] (seq pair)]
340+
(write-out k)
341+
(.write *out* " ")
342+
(write-out v)
343+
(when-let [more (seq (rest v))]
344+
(.write *out* " ")
345+
(recur more))))))
346+
347+
(alter-var-root #'*print-pprint-dispatch* (constantly simple-dispatch))
348+
349+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
350+
;; Pretty Printing Public API ;;
351+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
352+
353+
(defn write-out
354+
[object]
355+
(let [length-reached? (and *current-length*
356+
*print-length*
357+
(>= *current-length* *print-length*))]
358+
(if *print-pretty*
359+
(if length-reached?
360+
(print "...")
361+
(do
362+
(when-let [l *current-length*]
363+
(set! *current-length* (inc l)))
364+
(*print-pprint-dispatch* object)))
365+
(pr object))))
366+
367+
(defn pprint
368+
"Pretty print ``object`` to the given ``writer``.
369+
370+
If no ``writer`` is given, the value bound to :lpy:var:`basilisp.core/*out*` is
371+
used."
372+
([object]
373+
(pprint object *out*))
374+
([object writer]
375+
(binding [*out* (get-pretty-writer writer)
376+
*print-pretty* true]
377+
(write-out object)
378+
(newline))))
379+
380+
(defn pp
381+
"Print the last thing output to the REPL.
382+
383+
Equivalent to calling ``(pprint *1)``."
384+
[]
385+
(pprint *1))
3386

4387
(defn print-table
5388
"Print a collection of maps as a table to the buffer currently bound to

0 commit comments

Comments
 (0)