Adapting a functional pretty-printer to Clojure

[steven...@gmail.com]

Hello everyone,

I looked at Wadler's "A Prettier Printer" paper (http://
homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf) and did a
rote translation of it into Clojure. Then I wrote printing routines
for sequences and maps -- very barebones. They work OK:

user> (def something '(a b c d (e f g h i) j k (l m n) (o p q r s t u
v) w x y (z)))
#'user/something
user> (pp something 20)
nil
(a
b
c
d
(e f g h i)
j
k
(l m n)
(o p q r s t u v)
w
x
y
(z))
user> (def things {:one "another" :two {:map "inside" :a "map"} :three
[1 2 3 4 5] :four "still making things up" :five :done})
#'user/things
user> (pp things)
nil
{:three [1 2 3 4 5],
:one "another",
:five :done,
:four "still making things up",
:two {:a "map", :map "inside"}}
user>
user> (pp (bean (. java.awt.Color black)))
nil
{:RGB -16777216,
:class class java.awt.Color,
:red 0,
:colorSpace java.awt.color.ICC_ColorSpace@17bf9b45,
:transparency 1,
:blue 0,
:green 0,
:alpha 255}

BUT -- Wadler's implementation is for Haskell, so my transcription
predictably blows up with a stack overflow:

user> (pp (range 1000))
[Thrown class java.lang.StackOverflowError]

Restarts:
0: [ABORT] Return to SLIME's top level.

Backtrace:
0: java.lang.Number.<init>(Number.java:32)
1: java.lang.Integer.<init>(Integer.java:602)
2: sun.reflect.GeneratedMethodAccessor27.invoke(Unknown Source)
3: sun.reflect.DelegatingMethodAccessorImpl.invoke
(DelegatingMethodAccessorImpl.java:25)
4: java.lang.reflect.Method.invoke(Method.java:597)
5: clojure.lang.Reflector.invokeMatchingMethod(Reflector.java:82)
6: clojure.lang.Reflector.invokeNoArgInstanceMember(Reflector.java:
245)
7: user.fn__4400.invoke(pretty.clj:98)


What could be some good strategies to adapt the code I have here to
Clojure, where tail calls are not eliminated and structs are not lazy?


(defstruct NIL :type)
(defstruct CONCAT :type :doc1 :doc2)
(defstruct NEST :type :level :doc)
(defstruct TEXT :type :contents)
(defstruct LINE :type)
(defstruct UNION :type :doc1 :doc2)

(defn doc-nil []
(struct NIL :NIL))

(defn doc-concat [x y]
(struct CONCAT :CONCAT x y))

(defn doc-nest [i x]
(struct NEST :NEST i x))

(defn doc-text [s]
(struct TEXT :TEXT s))

(defn doc-line []
(struct LINE :LINE))

(defn doc-union [x y]
(struct UNION :UNION x y))

(defstruct Nil :type)
(defstruct Text :type :contents :rest)
(defstruct Line :type :level :rest)

(defmulti flatten :type)
(defmethod flatten :NIL [x] x)
(defmethod flatten :TEXT [x] x)
(defmethod flatten :CONCAT [x]
(doc-concat (flatten (:doc1 x))
(flatten (:doc2 x))))
(defmethod flatten :NEST [x]
(doc-nest (:level x)
(flatten (:doc x))))
(defmethod flatten :LINE [x]
(doc-text " "))
(defmethod flatten :UNION [x]
(flatten (:doc1 x)))

(defmulti layout :type)
(defmethod layout :Nil [x] "")
(defmethod layout :Text [x]
(lazy-cat (:contents x)
(layout (:rest x))))
(defmethod layout :Line [x]
(lazy-cat (lazy-cons \newline
(replicate (:level x) \space))
(layout (:rest x))))

(defn group [x]
(doc-union (flatten x) x))

(defmulti fits (fn [w x] (if (< w 0)
:ZERO
(:type x))))
(defmethod fits :ZERO [w x] false)
(defmethod fits :Nil [w x] true)
(defmethod fits :Line [w x] true)
(defmethod fits :Text [w x]
(fits (- w (.length (:contents x)))
(:rest x)))

(defn better [w k x y]
(if (fits (- w k) x)
x
y))

(defmulti be (fn [w k d]
(if (empty? d)
:EMPTY
(:type (second (first d))))))

(defmethod be :EMPTY [w k d]
(struct Nil :Nil))
(defmethod be :NIL [w k d]
(be w k (rest d)))
(defmethod be :CONCAT [w k d]
(let [level (first (first d))
doc (second (first d))]
(be w k (lazy-cons [level,(:doc1 doc)]
(lazy-cons [level,(:doc2 doc)] (rest d))))))
(defmethod be :NEST [w k d]
(let [level (first (first d))
doc (second (first d))]
(be w k (lazy-cons [(+ level (:level doc)), (:doc doc)]
(rest d)))))
(defmethod be :TEXT [w k d]
(let [doc (second (first d))]
(struct Text :Text (:contents doc)
(be w (+ k (.length (:contents doc)))
(rest d)))))
(defmethod be :LINE [w k d]
(let [level (first (first d))]
(struct Line :Line level (be w level (rest d)))))
(defmethod be :UNION [w k d]
(let [level (first (first d))
doc (second (first d))]
(better w k (be w k (lazy-cons [level,(:doc1 doc)] (rest d)))
(be w k (lazy-cons [level,(:doc2 doc)] (rest d))))))

(defn best [w k x]
(be w k (list [0,x])))

(defn pretty [w x]
(layout (best w 0 x)))

(defn show-dispatch [x]
(cond (seq? x)
:list
(map? x)
:map
true
:default))


(defmulti show show-dispatch)

(def show-list-children)
(defn show-list-children [x]
(cond (empty? x)
(doc-nil)
(= (count x) 1)
(show (first x))
true
(reduce doc-concat
(list (show (first x))
(doc-line)
(show-list-children (rest x))))))

(defn show-list-braces [x]
(reduce doc-concat (list (doc-text "(")
(doc-nest 1 (show-list-children x))
(doc-text ")"))))



(defn show-map-item [x]
(reduce doc-concat (list (show (first x))
(doc-text " ")
(doc-nest (+ (.length (pr-str (first x)))
1)
(show (second x))))))


(def show-map-items)
(defn show-map-items [x]
(cond (empty? x)
(doc-nil)
(= (count x) 1)
(show-map-item (first x))
true
(reduce doc-concat
(list (show-map-item (first x))
(doc-text ",")
(doc-line)
(show-map-items (rest x))))))

(defn show-map-braces [x]
(reduce doc-concat (list (doc-text "{")
(doc-nest 1 (show-map-items (seq x)))
(doc-text "}"))))



(defmethod show :default [x]
(doc-text (pr-str x)))
(defmethod show :list [x]
(group (show-list-braces x)))
(defmethod show :map [x]
(group (show-map-braces x)))


(defn pp
([obj width]
(print (apply str (pretty width (show obj)))))
([obj]
(pp obj 80)))

[Chouser]

On Tue, Nov 18, 2008 at 11:29 AM, stev...@acm.org
<steven...@gmail.com> wrote:
>
> I looked at Wadler's "A Prettier Printer" paper (http://
> homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf) and did a
> rote translation of it into Clojure. Then I wrote printing routines
> for sequences and maps -- very barebones. They work OK:

I started working on a pretty-printer as well. I wouldn't show it to
anybody yet, but I also don't want any unnecessary duplicated effort.
So I'll go ahead and show what I've got so far, and then we can decide
how to proceed. I have no interest in pursuing my solution if it's not
a good approach, or if anyone else would rather pursue it.

That is, I want to use a pretty printer, not necessarily write one. :-)

> user> (def something '(a b c d (e f g h i) j k (l m n) (o p q r s t u
> v) w x y (z)))
> #'user/something
> user> (pp something 20)

I don't have nice API yet, so for now I have to use binding:

user=> (binding [*max-width* 20] (pprint something))

(a
b
c
d
(e f g h i)
j
k
(l m n)
(o p q r s t u v)
w
x
y
(z))

> user> (def things {:one "another" :two {:map "inside" :a "map"} :three
> [1 2 3 4 5] :four "still making things up" :five :done})
> #'user/things
> user> (pp things)

user=> (pprint things)
{:five
:done

:three
[1 2 3 4 5]

:two
{:a "map", :map "inside"}

:four
"still making things up"

:one
"another"}

I still need to add commas and collapse key/vals onto a single line
when possible.

> user> (pp (range 1000))
> [Thrown class java.lang.StackOverflowError]

user=> (pprint (range 5000))
(0
1
2
3
4
[...manually snipped here...]
4996
4997
4998
4999)

Not a problem, though I don't have *line-limit* yet.

I allow \newlines to print, which helps with long multi-line strings:

(defn
gen-and-load-class
"Generates and immediately loads the bytecode for the specified
class. Note that a class generated this way can be loaded only once
- the JVM supports only one class with a given name per
classloader. Subsequent to generation you can import it into any
desired namespaces just like any other class. See gen-class for a
description of the options."
[name & options]
(let
[{:keys [name bytecode]} (apply gen-class (str name) options)]
(.. clojure.lang.RT ROOT_CLASSLOADER (defineClass (str name) bytecode))))

I'd like to add a *detect-code* option that looks for "well-known"
symbols that are used in code (defn, let, etc.) and can format the
required args differently than the "rest" args. This would allow some
code forms to look more natural.

Anyway, it's definitely a work in progress. What I've got so far is
attached. All thoughts and comments are welcome.
--Chouser

[Meikel Brandmeyer]

Hi,

Am 18.11.2008 um 17:29 schrieb stev...@acm.org:

> What could be some good strategies to adapt the code I have here to
> Clojure, where tail calls are not eliminated and structs are not lazy?

There is the lazy-map package[1], which also allows lazy (struct)maps.
However it is not updated to 1094+, yet.

I only skimmed through your code and I don't know the paper, but
maybe I can give some general tips.

As always: don't copy code blindly! Take a step back and look from a
distance, how you can *translate* the code. For example, in the
show-list-children function, the recursion is just used for iteration.
It starts with x, do something to (first x) and then calls itself
with (rest x). So the first step is to translate this into a loop
recur pair. The next step is to see, that one can also write this
as (doseq [child x] (do-something-to x)), or in case its the result
you are interested in and not the side-effects: (map #(do-something-to
%) x).

So don't just copy the code, but understand what it does and then
ask: "how would I do this in Clojure?"

Stuart's "PCL goes Clojure" series[2] is great example for this.

Just my 2¢.

Sincerely
Meikel

[1]: http://kotka.de/projects/clojure/lazy-map.html
[2]: http://blog.thinkrelevance.com/2008/9/16/pcl-clojure

[steven...@gmail.com]

On Nov 18, 12:03 pm, Chouser <chou...@gmail.com> wrote:
> On Tue, Nov 18, 2008 at 11:29 AM, steve...@acm.org

>
> <steven.hu...@gmail.com> wrote:
>
> > I looked at Wadler's "A Prettier Printer" paper (http://
> > homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf) and did a
> > rote translation of it into Clojure. Then I wrote printing routines
> > for sequences and maps -- very barebones. They work OK:
>
> I started working on a pretty-printer as well.  I wouldn't show it to
> anybody yet, but I also don't want any unnecessary duplicated effort.
> So I'll go ahead and show what I've got so far, and then we can decide
> how to proceed. I have no interest in pursuing my solution if it's not
> a good approach, or if anyone else would rather pursue it.
>
> That is, I want to use a pretty printer, not necessarily write one. :-)

I feel the same way, mostly.

I'm very new to Clojure and not all that experienced in Lisp or
functional programming in general. That's why I started with a port of
an existing skeletal implementation. I think the main advantage of
Wadler's approach -- not to be confused with my port, which I am sure
is in need of fixing-- is that it is bounded -- i.e. the decision to
print horizontally or vertically is made after looking ahead W
characters (W being the line width).

Your implementation needs to get the whole value of pr-str before
deciding that it is too long to put on a single line. But then, your
implementation actually works and doesn't run out of stack space on
short lists. :-)

On that topic, my pp function makes no sense -- it should use doseq to
take advantage of the laziness.

(defn pp
([obj width]

(doseq char (pretty width (show obj))
(print char)))

[Chouser]

On Tue, Nov 18, 2008 at 1:05 PM, stev...@acm.org
<steven...@gmail.com> wrote:
>
> Your implementation needs to get the whole value of pr-str before
> deciding that it is too long to put on a single line.

That's certainly what it does, but I don't think it has to. My plan
was to use *print-length* and *print-level* to cause pr-str to bail
out if it's getting too long. I can't decide if this general approach
is an ugly hack or an elegant re-use of existing code.

> But then, your implementation actually works and doesn't run out of
> stack space on short lists. :-)

I wanted to post what I had right away, but I will now take the time
to understand your code, so I can come up with own opinion about how
we ought to proceed.

--Chouser

[steven...@gmail.com]

On Nov 18, 12:53 pm, Meikel Brandmeyer <m...@kotka.de> wrote:

> As always: don't copy code blindly! Take a step back and look from a
> distance, how you can *translate* the code. For example, in the
> show-list-children function, the recursion is just used for iteration.
> It starts with x, do something to (first x) and then calls itself
> with (rest x). So the first step is to translate this into a loop
> recur pair. The next step is to see, that one can also write this
> as (doseq [child x] (do-something-to x)), or in case its the result
> you are interested in and not the side-effects: (map #(do-something-to
> %) x).
>
> So don't just copy the code, but understand what it does and then
> ask: "how would I do this in Clojure?"

Thanks for the advice. I think this works for show-list-children:

(defn insert-line [x y]
(doc-concat x (doc-concat (doc-line) y)))

(defn show-list-children [x]
(cond (empty? x)
(doc-nil)
(= (count x) 1)
(show (first x))
true

(reduce insert-line (map show x))))

Unfortunately the problem spot is:

(defmethod be :TEXT [w k d]
(let [doc (second (first d))]
(struct Text :Text (:contents doc)
(be w (+ k (.length (:contents doc)))
(rest d)))))

which I think I'll need to make lazy somehow.

-- Steve

[steven...@gmail.com]

On Nov 18, 1:12 pm, Chouser <chou...@gmail.com> wrote:
> On Tue, Nov 18, 2008 at 1:05 PM, steve...@acm.org

Thanks. I definitely recommend the original paper --
http://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf --
even if you don't know Haskell. It's short and to the point.

[steven...@gmail.com]

On Nov 18, 1:20 pm, "steve...@acm.org" <steven.hu...@gmail.com> wrote:

> Thanks for the advice. I think this works for show-list-children:
>
> (defn insert-line [x y]
>   (doc-concat x (doc-concat (doc-line) y)))
>
> (defn show-list-children [x]
>   (cond (empty? x)
>         (doc-nil)
>         (= (count x) 1)
>         (show (first x))
>         true
>         (reduce insert-line (map show x))))

or maybe
(defn show-list-children [x]
(if (empty? x)
(doc-nil)

(reduce insert-line (map show x))))

:-p

-- Steve

[steven...@gmail.com]

I believe I have fixed all of my stack-space issues except for this
one annoying function (rewritten from the original since the
multimethod wasn't buying me much):

(defn flatten [x]
(let [type (:type x)]
(cond (or (= type :NIL) (= type :TEXT))
x
(= type :CONCAT)

(doc-concat (flatten (:doc1 x))
(flatten (:doc2 x)))

(= type :NEST)

(doc-nest (:level x)
(flatten (:doc x)))

(= type :LINE)
(doc-text " ")
(= type :UNION)
(recur (:doc1 x)))))

Any ideas?

[Chouser]

One option: You could use a seq instead of all the various structs.
This would allow you to remove all the doc-foo helper functions.
Instead of calling those helpers, in most cases you could simply build
a vector [:NIL] instead of (doc-nil), [:TEXT " "] instead of (doc-text
" "). That way, when you need to recurse, you could use a lazy
expression like (lazy-cat [:concat] [(flatten (:doc1 x))] [(flatten
(:doc2 x))])
This would of course require you to change everywhere that currently
expects a struct with a :type to instead use (first x) for the type
and the rest of the seq as args.

Is your current version visible anywhere? Perhaps a more holistic
look would reveal some other options.

--Chouser

[steven...@gmail.com]

On Nov 24, 8:17 pm, Chouser <chou...@gmail.com> wrote:
> One option: You could use a seq instead of all the various structs.

I took your advice and uploaded the rewrite to the files section in
Google Groups, filename is pretty-printer.clj. It doesn't get a stack
overflow anymore, but it runs out of heap space on my machine trying
to print (pp (range 100000)). (pp (range 75000)) works fine.

This approach might just be too inefficient -- perhaps it would be
best to implement the pretty-printer in an imperative style after all.

One reason I don't like this rewrite is that the doc-nil, doc-concat,
doc-union, doc-line, and doc-text operators are missing. They form an
API for custom pretty-printing layouts. For example, with lazy-cats
the make-show-bracket function looks like this:

(defn make-show-brackets [lbrack rbrack]
(fn [x]
(lazy-cat [:CONCAT] [(lazy-cat [:TEXT] [lbrack])]
[(lazy-cat [:CONCAT] [(lazy-cat [:NEST] [1] [(show-
children x)])]
[(lazy-cat [:TEXT] [rbrack])])])))

but with an API from the Wadler paper this would look like:

(defn make-show-brackets [lbrack rbrack]
(fn [x]
(doc-concat (doc-text lbrack)
(doc-concat (doc-nest 1 (show-children x))
(doc-text rbrack)))))

or slightly more readably:

(defn make-show-brackets [lbrack rbrack]
(fn [x]
(reduce doc-concat (list (doc-text lbrack)
(doc-nest 1 (show-children x))
(doc-text rbrack)))))

Either way, there's a lot less noise than with the lazy-cat stuff...
the trouble is that the arguments need to be lazy. Macros might help,
though then the "reduce" trick above won't work.

-- Steve

[steven...@gmail.com]

On Nov 25, 12:22 am, "steve...@acm.org" <steven.hu...@gmail.com>
wrote:

> This approach might just be too inefficient -- perhaps it would be
> best to implement the pretty-printer in an imperative style after all.

OTOH it is pretty darn nifty...

user> (pp (clojure.xml/parse "http://catless.ncl.ac.uk/rdigest.rdf"))
{:tag :rdf:RDF,
:attrs {:xmlns "http://my.netscape.com/rdf/simple/0.9/",
:xmlns:rdf "http://www.w3.org/1999/02/22-rdf-syntax-ns#",
:xmlns:sy "http://purl.org/rss/1.0/modules/syndication/"},
:content [{:tag :channel,
:attrs nil,
:content [{:tag :title, :attrs nil, :content ["RISKS
Digest"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks"]}
{:tag :description,
:attrs nil,
:content ["The website of the RISKS Digest
mailing list"]}
{:tag :sy:updatePeriod, :attrs nil, :content
["daily"]}
{:tag :sy:updateFrequency, :attrs nil, :content
["1"]}
{:tag :sy:updateBase,
:attrs nil,
:content ["1970-01-01T03:13+00:00"]}]}
{:tag :image,
:attrs nil,
:content [{:tag :title, :attrs nil, :content ["RISKS"]}
{:tag :url,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Images/Misc/
rdigest.gif"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["Chinese hackers breach white house
computer systems"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj1"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["Hacker Tool Targeting MS08-067
Vulnerability"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj2"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["Lose the BlackBerry? Yes He Can,
Maybe: President-Elect Obama"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj3"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["Texas Suspends Massive Outsourcing
Contract"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj4"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["Driver Blames GPS System For Car-
Train Collision"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj5"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["Stop! Buses only! --What do you
mean, you ARE a bus?"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj6"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["Martian deep freeze: NASA's Mars
Lander dies in the dark"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj7"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["The \"Two Focaccia Buttons Defense
\""]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj8"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["Risks of assuming constant hours in
a day"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj9"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["Excel auto-formatting"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj10"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["Texting bug hits the Google phone"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj11"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["Vintage IBM tape drive in Apollo
moon dust rescue"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj12"]}]}
nil
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["gnus-mime-print-part vs. Mom's
room"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj13"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["Re: BBC Domesday Project"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj14"]}]}
{:tag :item,
:attrs nil,
:content [{:tag :title,
:attrs nil,
:content ["Re: Poison pill auto-disclosure"]}
{:tag :link,
:attrs nil,
:content ["http://catless.ncl.ac.uk/Risks/
25.45.html#subj15"]}]}]}
user>

[steven...@gmail.com]

On Nov 25, 12:50 am, "steve...@acm.org" <steven.hu...@gmail.com>
wrote:

> On Nov 25, 12:22 am, "steve...@acm.org" <steven.hu...@gmail.com>
> wrote:
>
> > This approach might just be too inefficient -- perhaps it would be
> > best to implement the pretty-printer in an imperative style after all.
>
> OTOH it is pretty darn nifty...

...or would be if Google Groups didn't wrap so well...

[Rich Hickey]

On Nov 25, 12:51 am, "steve...@acm.org" <steven.hu...@gmail.com>

I've added trampoline, which could significantly ease the work you are
trying to do:

http://groups.google.com/group/clojure/msg/3addf875319c5c10

Rich