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 [EMAIL PROTECTED],
: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)))
--~--~---------~--~----~------------~-------~--~----~
You received this message because you are subscribed to the Google Groups
"Clojure" group.
To post to this group, send email to [email protected]
To unsubscribe from this group, send email to [EMAIL PROTECTED]
For more options, visit this group at
http://groups.google.com/group/clojure?hl=en
-~----------~----~----~----~------~----~------~--~---
