Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Started adding cl-format code.

It loads, many tests run, about 75 fails.  Mostly due to type mismatches.  Probably 3 or 4 actual code problems revealed in tests.
  • Loading branch information...
commit c725895e907382e5f6636ecbaa6ae96ad96dd7b4 1 parent c4c9341
@dmiller dmiller authored
View
35 Clojure/Clojure.Source/Clojure.Source.csproj
@@ -166,6 +166,41 @@
<SubType>Designer</SubType>
</EmbeddedResource>
</ItemGroup>
+ <ItemGroup>
+ <None Include="clojure\pprint.clj">
+ <CopyToOutputDirectory>PreserveNewest</CopyToOutputDirectory>
+ </None>
+ <None Include="clojure\pprint\cl_format.clj">
+ <CopyToOutputDirectory>PreserveNewest</CopyToOutputDirectory>
+ </None>
+ <None Include="clojure\pprint\column_writer.clj">
+ <CopyToOutputDirectory>PreserveNewest</CopyToOutputDirectory>
+ </None>
+ <None Include="clojure\pprint\dispatch.clj">
+ <CopyToOutputDirectory>PreserveNewest</CopyToOutputDirectory>
+ </None>
+ <None Include="clojure\pprint\pprint_base.clj">
+ <CopyToOutputDirectory>PreserveNewest</CopyToOutputDirectory>
+ </None>
+ <None Include="clojure\pprint\pretty_writer.clj">
+ <CopyToOutputDirectory>PreserveNewest</CopyToOutputDirectory>
+ </None>
+ <None Include="clojure\pprint\utilities.clj">
+ <CopyToOutputDirectory>PreserveNewest</CopyToOutputDirectory>
+ </None>
+ <None Include="clojure\test_clojure\pprint.clj">
+ <CopyToOutputDirectory>PreserveNewest</CopyToOutputDirectory>
+ </None>
+ <None Include="clojure\test_clojure\pprint\test_cl_format.clj">
+ <CopyToOutputDirectory>PreserveNewest</CopyToOutputDirectory>
+ </None>
+ <None Include="clojure\test_clojure\pprint\test_helper.clj">
+ <CopyToOutputDirectory>PreserveNewest</CopyToOutputDirectory>
+ </None>
+ <None Include="clojure\test_clojure\pprint\test_pretty.clj">
+ <CopyToOutputDirectory>PreserveNewest</CopyToOutputDirectory>
+ </None>
+ </ItemGroup>
<Import Project="$(MSBuildToolsPath)\Microsoft.CSharp.targets" />
<!-- To modify your build process, add your task inside one of the targets below and uncomment it.
Other similar extension points exist, see Microsoft.Common.targets.
View
2  Clojure/Clojure.Source/clojure/core_print.clj
@@ -10,7 +10,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; printing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(import '(System.IO.System.IO.TextWriter)) ;;; was (import '(java.io Writer)) (I have replaced ^Writer with ^System.IO.TextWriter throughout
+(import '(System.IO.TextWriter)) ;;; was (import '(java.io Writer)) (I have replaced ^Writer with ^System.IO.TextWriter throughout
;; Other global replaces: .write => .Write, .append => .Write, ^Class => ^Type, ^Character => ^Char
(def
^{:doc "*print-length* controls how many items of each collection the
View
48 Clojure/Clojure.Source/clojure/pprint.clj
@@ -0,0 +1,48 @@
+;;; pprint.clj -- Pretty printer and Common Lisp compatible format function (cl-format) for Clojure
+
+; Copyright (c) Rich Hickey. All rights reserved.
+; The use and distribution terms for this software are covered by the
+; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+; which can be found in the file epl-v10.html at the root of this distribution.
+; By using this software in any fashion, you are agreeing to be bound by
+; the terms of this license.
+; You must not remove this notice, or any other, from this software.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+
+(ns
+ ^{:author "Tom Faulhaber",
+ :doc "A Pretty Printer for Clojure
+
+clojure.pprint implements a flexible system for printing structured data
+in a pleasing, easy-to-understand format. Basic use of the pretty printer is
+simple, just call pprint instead of println. More advanced users can use
+the building blocks provided to create custom output formats.
+
+Out of the box, pprint supports a simple structured format for basic data
+and a specialized format for Clojure source code. More advanced formats,
+including formats that don't look like Clojure data at all like XML and
+JSON, can be rendered by creating custom dispatch functions.
+
+In addition to the pprint function, this module contains cl-format, a text
+formatting function which is fully compatible with the format function in
+Common Lisp. Because pretty printing directives are directly integrated with
+cl-format, it supports very concise custom dispatch. It also provides
+a more powerful alternative to Clojure's standard format function.
+
+See documentation for pprint and cl-format for more information or
+complete documentation on the the clojure web site on github.",
+ :added "1.2"}
+ clojure.pprint
+ (:refer-clojure :exclude (deftype)))
+
+
+(load "pprint/utilities")
+(load "pprint/column_writer")
+(load "pprint/pretty_writer")
+(load "pprint/pprint_base")
+(load "pprint/cl_format")
+(load "pprint/dispatch")
+
+nil
View
1,896 Clojure/Clojure.Source/clojure/pprint/cl_format.clj
@@ -0,0 +1,1896 @@
+;;; cl_format.clj -- part of the pretty printer for Clojure
+
+; Copyright (c) Rich Hickey. All rights reserved.
+; The use and distribution terms for this software are covered by the
+; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+; which can be found in the file epl-v10.html at the root of this distribution.
+; By using this software in any fashion, you are agreeing to be bound by
+; the terms of this license.
+; You must not remove this notice, or any other, from this software.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+
+
+;; This module implements the Common Lisp compatible format function as documented
+;; in "Common Lisp the Language, 2nd edition", Chapter 22 (available online at:
+;; http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000)
+
+(in-ns 'clojure.pprint)
+
+;;; Forward references
+(declare compile-format)
+(declare execute-format)
+(declare init-navigator)
+;;; End forward references
+
+(defn cl-format
+ "An implementation of a Common Lisp compatible format function. cl-format formats its
+arguments to an output stream or string based on the format control string given. It
+supports sophisticated formatting of structured data.
+
+Writer is an instance of java.io.Writer, true to output to *out* or nil to output
+to a string, format-in is the format control string and the remaining arguments
+are the data to be formatted.
+
+The format control string is a string to be output with embedded 'format directives'
+describing how to format the various arguments passed in.
+
+If writer is nil, cl-format returns the formatted result string. Otherwise, cl-format
+returns nil.
+
+For example:
+ (let [results [46 38 22]]
+ (cl-format true \"There ~[are~;is~:;are~]~:* ~d result~:p: ~{~d~^, ~}~%\"
+ (count results) results))
+
+Prints to *out*:
+ There are 3 results: 46, 38, 22
+
+Detailed documentation on format control strings is available in the \"Common Lisp the
+Language, 2nd edition\", Chapter 22 (available online at:
+http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000)
+and in the Common Lisp HyperSpec at
+http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm
+"
+ {:added "1.2",
+ :see-also [["http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html#SECTION002633000000000000000"
+ "Common Lisp the Language"]
+ ["http://www.lispworks.com/documentation/HyperSpec/Body/22_c.htm"
+ "Common Lisp HyperSpec"]]}
+ [writer format-in & args]
+ (let [compiled-format (if (string? format-in) (compile-format format-in) format-in)
+ navigator (init-navigator args)]
+ (execute-format writer compiled-format navigator)))
+
+(def ^{:private true} *format-str* nil)
+
+(defn- format-error [message offset]
+ (let [full-message (str message \newline *format-str* \newline
+ (apply str (repeat offset \space)) "^" \newline)]
+ (throw (Exception. full-message)))) ;;; RuntimeException
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Argument navigators manage the argument list
+;;; as the format statement moves through the list
+;;; (possibly going forwards and backwards as it does so)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defstruct ^{:private true}
+ arg-navigator :seq :rest :pos )
+
+(defn- init-navigator
+ "Create a new arg-navigator from the sequence with the position set to 0"
+ {:skip-wiki true}
+ [s]
+ (let [s (seq s)]
+ (struct arg-navigator s s 0)))
+
+;; TODO call format-error with offset
+(defn- next-arg [ navigator ]
+ (let [ rst (:rest navigator) ]
+ (if rst
+ [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))]
+ (throw (new Exception "Not enough arguments for format definition")))))
+
+(defn- next-arg-or-nil [navigator]
+ (let [rst (:rest navigator)]
+ (if rst
+ [(first rst) (struct arg-navigator (:seq navigator ) (next rst) (inc (:pos navigator)))]
+ [nil navigator])))
+
+;; Get an argument off the arg list and compile it if it's not already compiled
+(defn- get-format-arg [navigator]
+ (let [[raw-format navigator] (next-arg navigator)
+ compiled-format (if (instance? String raw-format)
+ (compile-format raw-format)
+ raw-format)]
+ [compiled-format navigator]))
+
+(declare relative-reposition)
+
+(defn- absolute-reposition [navigator position]
+ (if (>= position (:pos navigator))
+ (relative-reposition navigator (- (:pos navigator) position))
+ (struct arg-navigator (:seq navigator) (drop position (:seq navigator)) position)))
+
+(defn- relative-reposition [navigator position]
+ (let [newpos (+ (:pos navigator) position)]
+ (if (neg? position)
+ (absolute-reposition navigator newpos)
+ (struct arg-navigator (:seq navigator) (drop position (:rest navigator)) newpos))))
+
+(defstruct ^{:private true}
+ compiled-directive :func :def :params :offset)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; When looking at the parameter list, we may need to manipulate
+;;; the argument list as well (for 'V' and '#' parameter types).
+;;; We hide all of this behind a function, but clients need to
+;;; manage changing arg navigator
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; TODO: validate parameters when they come from arg list
+(defn- realize-parameter [[param [raw-val offset]] navigator]
+ (let [[real-param new-navigator]
+ (cond
+ (contains? #{ :at :colon } param) ;pass flags through unchanged - this really isn't necessary
+ [raw-val navigator]
+
+ (= raw-val :parameter-from-args)
+ (next-arg navigator)
+
+ (= raw-val :remaining-arg-count)
+ [(count (:rest navigator)) navigator]
+
+ true
+ [raw-val navigator])]
+ [[param [real-param offset]] new-navigator]))
+
+(defn- realize-parameter-list [parameter-map navigator]
+ (let [[pairs new-navigator]
+ (map-passing-context realize-parameter navigator parameter-map)]
+ [(into {} pairs) new-navigator]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Functions that support individual directives
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Common handling code for ~A and ~S
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare opt-base-str)
+
+(def ^{:private true}
+ special-radix-markers {2 "#b" 8 "#o", 16 "#x"})
+
+(defn- format-simple-number [n]
+ (cond
+ (integer? n) (if (= *print-base* 10)
+ (str n (if *print-radix* "."))
+ (str
+ (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r")))
+ (opt-base-str *print-base* n)))
+ (ratio? n) (str
+ (if *print-radix* (or (get special-radix-markers *print-base*) (str "#" *print-base* "r")))
+ (opt-base-str *print-base* (.numerator n))
+ "/"
+ (opt-base-str *print-base* (.denominator n)))
+ :else nil))
+
+(defn- format-ascii [print-func params arg-navigator offsets]
+ (let [ [arg arg-navigator] (next-arg arg-navigator)
+ ^String base-output (or (format-simple-number arg) (print-func arg))
+ base-width (.Length base-output) ;;; length
+ min-width (+ base-width (:minpad params))
+ width (if (>= min-width (:mincol params))
+ min-width
+ (+ min-width
+ (* (+ (quot (- (:mincol params) min-width 1)
+ (:colinc params) )
+ 1)
+ (:colinc params))))
+ chars (apply str (repeat (- width base-width) (:padchar params)))]
+ (if (:at params)
+ (print (str chars base-output))
+ (print (str base-output chars)))
+ arg-navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for the integer directives ~D, ~X, ~O, ~B and some
+;;; of ~R
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- integral?
+ "returns true if a number is actually an integer (that is, has no fractional part)"
+ [x]
+ (cond
+ (integer? x) true
+ (decimal? x) true ;;; TODO: FIX THIS (>= (.ulp (.stripTrailingZeros (bigdec 0))) 1) ; true iff no fractional part DM: ??????? doesn't mention x!!!
+ (float? x) (= x (Math/Floor x)) ;;; Math/floor
+ (ratio? x) (let [^clojure.lang.Ratio r x]
+ (= 0 (rem (.numerator r) (.denominator r))))
+ :else false))
+
+(defn- remainders
+ "Return the list of remainders (essentially the 'digits') of val in the given base"
+ [base val]
+ (reverse
+ (first
+ (consume #(if (pos? %)
+ [(rem % base) (quot % base)]
+ [nil nil])
+ val))))
+
+;;; TODO: xlated-val does not seem to be used here.
+(defn- base-str
+ "Return val as a string in the given base"
+ [base val]
+ (if (zero? val)
+ "0"
+ (let [xlated-val (cond
+ (float? val) (bigdec val)
+ (ratio? val) (let [^clojure.lang.Ratio r val]
+ (/ (.numerator r) (.denominator r)))
+ :else val)]
+ (apply str
+ (map
+ #(if (< % 10) (char (+ (int \0) %)) (char (+ (int \a) (- % 10))))
+ (remainders base val))))))
+
+(def ^{:private true}
+ java-base-formats {8 "%o", 10 "%d", 16 "%x"})
+
+(defn- opt-base-str
+ "Return val as a string in the given base, using clojure.core/format if supported
+for improved performance"
+ [base val]
+ (let [format-str (get java-base-formats base)]
+ (if (and format-str (integer? val))
+ (clojure.core/format format-str val)
+ (base-str base val))))
+
+(defn- group-by* [unit lis]
+ (reverse
+ (first
+ (consume (fn [x] [(seq (reverse (take unit x))) (seq (drop unit x))]) (reverse lis)))))
+
+(defn- format-integer [base params arg-navigator offsets]
+ (let [[arg arg-navigator] (next-arg arg-navigator)]
+ (if (integral? arg)
+ (let [neg (neg? arg)
+ pos-arg (if neg (- arg) arg)
+ raw-str (opt-base-str base pos-arg)
+ group-str (if (:colon params)
+ (let [groups (map #(apply str %) (group-by* (:commainterval params) raw-str))
+ commas (repeat (count groups) (:commachar params))]
+ (apply str (next (interleave commas groups))))
+ raw-str)
+ ^String signed-str (cond
+ neg (str "-" group-str)
+ (:at params) (str "+" group-str)
+ true group-str)
+ padded-str (if (< (.Length signed-str) (:mincol params)) ;;; length
+ (str (apply str (repeat (- (:mincol params) (.Length signed-str)) ;;; length
+ (:padchar params)))
+ signed-str)
+ signed-str)]
+ (print padded-str))
+ (format-ascii print-str {:mincol (:mincol params) :colinc 1 :minpad 0
+ :padchar (:padchar params) :at true}
+ (init-navigator [arg]) nil))
+ arg-navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for english formats (~R and ~:R)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true}
+ english-cardinal-units
+ ["zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"
+ "ten" "eleven" "twelve" "thirteen" "fourteen"
+ "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"])
+
+(def ^{:private true}
+ english-ordinal-units
+ ["zeroth" "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth"
+ "tenth" "eleventh" "twelfth" "thirteenth" "fourteenth"
+ "fifteenth" "sixteenth" "seventeenth" "eighteenth" "nineteenth"])
+
+(def ^{:private true}
+ english-cardinal-tens
+ ["" "" "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety"])
+
+(def ^{:private true}
+ english-ordinal-tens
+ ["" "" "twentieth" "thirtieth" "fortieth" "fiftieth"
+ "sixtieth" "seventieth" "eightieth" "ninetieth"])
+
+;; We use "short scale" for our units (see http://en.wikipedia.org/wiki/Long_and_short_scales)
+;; Number names from http://www.jimloy.com/math/billion.htm
+;; We follow the rules for writing numbers from the Blue Book
+;; (http://www.grammarbook.com/numbers/numbers.asp)
+(def ^{:private true}
+ english-scale-numbers
+ ["" "thousand" "million" "billion" "trillion" "quadrillion" "quintillion"
+ "sextillion" "septillion" "octillion" "nonillion" "decillion"
+ "undecillion" "duodecillion" "tredecillion" "quattuordecillion"
+ "quindecillion" "sexdecillion" "septendecillion"
+ "octodecillion" "novemdecillion" "vigintillion"])
+
+(defn- format-simple-cardinal
+ "Convert a number less than 1000 to a cardinal english string"
+ [num]
+ (let [hundreds (quot num 100)
+ tens (rem num 100)]
+ (str
+ (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred"))
+ (if (and (pos? hundreds) (pos? tens)) " ")
+ (if (pos? tens)
+ (if (< tens 20)
+ (nth english-cardinal-units tens)
+ (let [ten-digit (quot tens 10)
+ unit-digit (rem tens 10)]
+ (str
+ (if (pos? ten-digit) (nth english-cardinal-tens ten-digit))
+ (if (and (pos? ten-digit) (pos? unit-digit)) "-")
+ (if (pos? unit-digit) (nth english-cardinal-units unit-digit)))))))))
+
+(defn- add-english-scales
+ "Take a sequence of parts, add scale numbers (e.g., million) and combine into a string
+offset is a factor of 10^3 to multiply by"
+ [parts offset]
+ (let [cnt (count parts)]
+ (loop [acc []
+ pos (dec cnt)
+ this (first parts)
+ remainder (next parts)]
+ (if (nil? remainder)
+ (str (apply str (interpose ", " acc))
+ (if (and (not (empty? this)) (not (empty? acc))) ", ")
+ this
+ (if (and (not (empty? this)) (pos? (+ pos offset)))
+ (str " " (nth english-scale-numbers (+ pos offset)))))
+ (recur
+ (if (empty? this)
+ acc
+ (conj acc (str this " " (nth english-scale-numbers (+ pos offset)))))
+ (dec pos)
+ (first remainder)
+ (next remainder))))))
+
+(defn- format-cardinal-english [params navigator offsets]
+ (let [[arg navigator] (next-arg navigator)]
+ (if (= 0 arg)
+ (print "zero")
+ (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs
+ parts (remainders 1000 abs-arg)]
+ (if (<= (count parts) (count english-scale-numbers))
+ (let [parts-strs (map format-simple-cardinal parts)
+ full-str (add-english-scales parts-strs 0)]
+ (print (str (if (neg? arg) "minus ") full-str)))
+ (format-integer ;; for numbers > 10^63, we fall back on ~D
+ 10
+ { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}
+ (init-navigator [arg])
+ { :mincol 0, :padchar 0, :commachar 0 :commainterval 0}))))
+ navigator))
+
+(defn- format-simple-ordinal
+ "Convert a number less than 1000 to a ordinal english string
+Note this should only be used for the last one in the sequence"
+ [num]
+ (let [hundreds (quot num 100)
+ tens (rem num 100)]
+ (str
+ (if (pos? hundreds) (str (nth english-cardinal-units hundreds) " hundred"))
+ (if (and (pos? hundreds) (pos? tens)) " ")
+ (if (pos? tens)
+ (if (< tens 20)
+ (nth english-ordinal-units tens)
+ (let [ten-digit (quot tens 10)
+ unit-digit (rem tens 10)]
+ (if (and (pos? ten-digit) (not (pos? unit-digit)))
+ (nth english-ordinal-tens ten-digit)
+ (str
+ (if (pos? ten-digit) (nth english-cardinal-tens ten-digit))
+ (if (and (pos? ten-digit) (pos? unit-digit)) "-")
+ (if (pos? unit-digit) (nth english-ordinal-units unit-digit))))))
+ (if (pos? hundreds) "th")))))
+
+(defn- format-ordinal-english [params navigator offsets]
+ (let [[arg navigator] (next-arg navigator)]
+ (if (= 0 arg)
+ (print "zeroth")
+ (let [abs-arg (if (neg? arg) (- arg) arg) ; some numbers are too big for Math/abs
+ parts (remainders 1000 abs-arg)]
+ (if (<= (count parts) (count english-scale-numbers))
+ (let [parts-strs (map format-simple-cardinal (drop-last parts))
+ head-str (add-english-scales parts-strs 1)
+ tail-str (format-simple-ordinal (last parts))]
+ (print (str (if (neg? arg) "minus ")
+ (cond
+ (and (not (empty? head-str)) (not (empty? tail-str)))
+ (str head-str ", " tail-str)
+
+ (not (empty? head-str)) (str head-str "th")
+ :else tail-str))))
+ (do (format-integer ;; for numbers > 10^63, we fall back on ~D
+ 10
+ { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}
+ (init-navigator [arg])
+ { :mincol 0, :padchar 0, :commachar 0 :commainterval 0})
+ (let [low-two-digits (rem arg 100)
+ not-teens (or (< 11 low-two-digits) (> 19 low-two-digits))
+ low-digit (rem low-two-digits 10)]
+ (print (cond
+ (and (= low-digit 1) not-teens) "st"
+ (and (= low-digit 2) not-teens) "nd"
+ (and (= low-digit 3) not-teens) "rd"
+ :else "th")))))))
+ navigator))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for roman numeral formats (~@R and ~@:R)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true}
+ old-roman-table
+ [[ "I" "II" "III" "IIII" "V" "VI" "VII" "VIII" "VIIII"]
+ [ "X" "XX" "XXX" "XXXX" "L" "LX" "LXX" "LXXX" "LXXXX"]
+ [ "C" "CC" "CCC" "CCCC" "D" "DC" "DCC" "DCCC" "DCCCC"]
+ [ "M" "MM" "MMM"]])
+
+(def ^{:private true}
+ new-roman-table
+ [[ "I" "II" "III" "IV" "V" "VI" "VII" "VIII" "IX"]
+ [ "X" "XX" "XXX" "XL" "L" "LX" "LXX" "LXXX" "XC"]
+ [ "C" "CC" "CCC" "CD" "D" "DC" "DCC" "DCCC" "CM"]
+ [ "M" "MM" "MMM"]])
+
+(defn- format-roman
+ "Format a roman numeral using the specified look-up table"
+ [table params navigator offsets]
+ (let [[arg navigator] (next-arg navigator)]
+ (if (and (number? arg) (> arg 0) (< arg 4000))
+ (let [digits (remainders 10 arg)]
+ (loop [acc []
+ pos (dec (count digits))
+ digits digits]
+ (if (empty? digits)
+ (print (apply str acc))
+ (let [digit (first digits)]
+ (recur (if (= 0 digit)
+ acc
+ (conj acc (nth (nth table pos) (dec digit))))
+ (dec pos)
+ (next digits))))))
+ (format-integer ;; for anything <= 0 or > 3999, we fall back on ~D
+ 10
+ { :mincol 0, :padchar \space, :commachar \, :commainterval 3, :colon true}
+ (init-navigator [arg])
+ { :mincol 0, :padchar 0, :commachar 0 :commainterval 0}))
+ navigator))
+
+(defn- format-old-roman [params navigator offsets]
+ (format-roman old-roman-table params navigator offsets))
+
+(defn- format-new-roman [params navigator offsets]
+ (format-roman new-roman-table params navigator offsets))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for character formats (~C)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true}
+ special-chars { 8 "Backspace", 9 "Tab", 10 "Newline", 13 "Return", 32 "Space"})
+
+(defn- pretty-character [params navigator offsets]
+ (let [[c navigator] (next-arg navigator)
+ as-int (int c)
+ base-char (bit-and as-int 127)
+ meta (bit-and as-int 128)
+ special (get special-chars base-char)]
+ (if (> meta 0) (print "Meta-"))
+ (print (cond
+ special special
+ (< base-char 32) (str "Control-" (char (+ base-char 64)))
+ (= base-char 127) "Control-?"
+ :else (char base-char)))
+ navigator))
+
+(defn- readable-character [params navigator offsets]
+ (let [[c navigator] (next-arg navigator)]
+ (condp = (:char-format params)
+ \o (cl-format true "\\o~3,'0o" (int c))
+ \u (cl-format true "\\u~4,'0x" (int c))
+ nil (pr c))
+ navigator))
+
+(defn- plain-character [params navigator offsets]
+ (let [[char navigator] (next-arg navigator)]
+ (print char)
+ navigator))
+
+;; Check to see if a result is an abort (~^) construct
+;; TODO: move these funcs somewhere more appropriate
+(defn- abort? [context]
+ (let [token (first context)]
+ (or (= :up-arrow token) (= :colon-up-arrow token))))
+
+;; Handle the execution of "sub-clauses" in bracket constructions
+(defn- execute-sub-format [format args base-args]
+ (second
+ (map-passing-context
+ (fn [element context]
+ (if (abort? context)
+ [nil context] ; just keep passing it along
+ (let [[params args] (realize-parameter-list (:params element) context)
+ [params offsets] (unzip-map params)
+ params (assoc params :base-args base-args)]
+ [nil (apply (:func element) [params args offsets])])))
+ args
+ format)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for real number formats
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; TODO - return exponent as int to eliminate double conversion
+(defn- float-parts-base
+ "Produce string parts for the mantissa (normalized 1-9) and exponent"
+ [^Object f]
+ (let [^String s (.ToLower (.ToString f)) ;;; .toLowerCase .toString
+ exploc (.IndexOf s \e)] ;;; .indexOf (int \e)
+ (if (neg? exploc)
+ (let [dotloc (.IndexOf s \.)] ;;; .indexOf (int \.)
+ (if (neg? dotloc)
+ [s (str (dec (count s)))]
+ [(str (subs s 0 dotloc) (subs s (inc dotloc))) (str (dec dotloc))]))
+ [(str (subs s 0 1) (subs s 2 exploc)) (subs s (inc exploc))])))
+
+
+(defn- float-parts
+ "Take care of leading and trailing zeros in decomposed floats"
+ [f]
+ (let [[m ^String e] (float-parts-base f)
+ m1 (rtrim m \0)
+ m2 (ltrim m1 \0)
+ delta (- (count m1) (count m2))
+ ^String e (if (and (pos? (count e)) (= (nth e 0) \+)) (subs e 1) e)]
+ (if (empty? m2)
+ ["0" 0]
+ [m2 (- (Int32/Parse e) delta)]))) ;;; (Integer/valueOf e)
+
+(defn- round-str [m e d w]
+ (if (or d w)
+ (let [len (count m)
+ round-pos (if d (+ e d 1))
+ round-pos (if (and w (< (inc e) (dec w))
+ (or (nil? round-pos) (< (dec w) round-pos)))
+ (dec w)
+ round-pos)
+ [m1 e1 round-pos len] (if (= round-pos 0)
+ [(str "0" m) (inc e) 1 (inc len)]
+ [m e round-pos len])]
+ (if round-pos
+ (if (neg? round-pos)
+ ["0" 0 false]
+ (if (> len round-pos)
+ (let [round-char (nth m1 round-pos)
+ ^String result (subs m1 0 round-pos)]
+ (if (>= (int round-char) (int \5))
+ (let [result-val (Int32/Parse result) ;;; Integer/valueOf
+ leading-zeros (subs result 0 (min (prefix-count result \0) (- round-pos 1)))
+ round-up-result (str leading-zeros
+ (.ToString (+ result-val ;;;String/valueOf
+ (if (neg? result-val) -1 1))))
+ expanded (> (count round-up-result) (count result))]
+ [round-up-result e1 expanded])
+ [result e1 false]))
+ [m e false]))
+ [m e false]))
+ [m e false]))
+
+(defn- expand-fixed [m e d]
+ (let [m1 (if (neg? e) (str (apply str (repeat (dec (- e)) \0)) m) m)
+ len (count m1)
+ target-len (if d (+ e d 1) (inc e))]
+ (if (< len target-len)
+ (str m1 (apply str (repeat (- target-len len) \0)))
+ m1)))
+
+(defn- insert-decimal
+ "Insert the decimal point at the right spot in the number to match an exponent"
+ [m e]
+ (if (neg? e)
+ (str "." m)
+ (let [loc (inc e)]
+ (str (subs m 0 loc) "." (subs m loc)))))
+
+(defn- get-fixed [m e d]
+ (insert-decimal (expand-fixed m e d) e))
+
+(defn- insert-scaled-decimal
+ "Insert the decimal point at the right spot in the number to match an exponent"
+ [m k]
+ (if (neg? k)
+ (str "." m)
+ (str (subs m 0 k) "." (subs m k))))
+
+;; the function to render ~F directives
+;; TODO: support rationals. Back off to ~D/~A is the appropriate cases
+(defn- fixed-float [params navigator offsets]
+ (let [w (:w params)
+ d (:d params)
+ [arg navigator] (next-arg navigator)
+ [sign abs] (if (neg? arg) ["-" (- arg)] ["+" arg])
+ [mantissa exp] (float-parts abs)
+ scaled-exp (+ exp (:k params))
+ add-sign (or (:at params) (neg? arg))
+ append-zero (and (not d) (<= (dec (count mantissa)) scaled-exp))
+ [rounded-mantissa scaled-exp expanded] (round-str mantissa scaled-exp
+ d (if w (- w (if add-sign 1 0))))
+ fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d)
+ prepend-zero (= (first fixed-repr) \.)]
+ (if w
+ (let [len (count fixed-repr)
+ signed-len (if add-sign (inc len) len)
+ prepend-zero (and prepend-zero (not (>= signed-len w)))
+ append-zero (and append-zero (not (>= signed-len w)))
+ full-len (if (or prepend-zero append-zero)
+ (inc signed-len)
+ signed-len)]
+ (if (and (> full-len w) (:overflowchar params))
+ (print (apply str (repeat w (:overflowchar params))))
+ (print (str
+ (apply str (repeat (- w full-len) (:padchar params)))
+ (if add-sign sign)
+ (if prepend-zero "0")
+ fixed-repr
+ (if append-zero "0")))))
+ (print (str
+ (if add-sign sign)
+ (if prepend-zero "0")
+ fixed-repr
+ (if append-zero "0"))))
+ navigator))
+
+
+;; the function to render ~E directives
+;; TODO: support rationals. Back off to ~D/~A is the appropriate cases
+;; TODO: define ~E representation for Infinity
+(defn- exponential-float [params navigator offsets]
+ (let [[arg navigator] (next-arg navigator)]
+ (loop [[mantissa exp] (float-parts (if (neg? arg) (- arg) arg))]
+ (let [w (:w params)
+ d (:d params)
+ e (:e params)
+ k (:k params)
+ expchar (or (:exponentchar params) \E)
+ add-sign (or (:at params) (neg? arg))
+ prepend-zero (<= k 0)
+ ^Int32 scaled-exp (- exp (dec k)) ;;; Integer
+ scaled-exp-str (str (Math/Abs scaled-exp)) ;;; Math/abs
+ scaled-exp-str (str expchar (if (neg? scaled-exp) \- \+)
+ (if e (apply str
+ (repeat
+ (- e
+ (count scaled-exp-str))
+ \0)))
+ scaled-exp-str)
+ exp-width (count scaled-exp-str)
+ base-mantissa-width (count mantissa)
+ scaled-mantissa (str (apply str (repeat (- k) \0))
+ mantissa
+ (if d
+ (apply str
+ (repeat
+ (- d (dec base-mantissa-width)
+ (if (neg? k) (- k) 0)) \0))))
+ w-mantissa (if w (- w exp-width))
+ [rounded-mantissa _ incr-exp] (round-str
+ scaled-mantissa 0
+ (cond
+ (= k 0) (dec d)
+ (pos? k) d
+ (neg? k) (dec d))
+ (if w-mantissa
+ (- w-mantissa (if add-sign 1 0))))
+ full-mantissa (insert-scaled-decimal rounded-mantissa k)
+ append-zero (and (= k (count rounded-mantissa)) (nil? d))]
+ (if (not incr-exp)
+ (if w
+ (let [len (+ (count full-mantissa) exp-width)
+ signed-len (if add-sign (inc len) len)
+ prepend-zero (and prepend-zero (not (= signed-len w)))
+ full-len (if prepend-zero (inc signed-len) signed-len)
+ append-zero (and append-zero (< full-len w))]
+ (if (and (or (> full-len w) (and e (> (- exp-width 2) e)))
+ (:overflowchar params))
+ (print (apply str (repeat w (:overflowchar params))))
+ (print (str
+ (apply str
+ (repeat
+ (- w full-len (if append-zero 1 0) )
+ (:padchar params)))
+ (if add-sign (if (neg? arg) \- \+))
+ (if prepend-zero "0")
+ full-mantissa
+ (if append-zero "0")
+ scaled-exp-str))))
+ (print (str
+ (if add-sign (if (neg? arg) \- \+))
+ (if prepend-zero "0")
+ full-mantissa
+ (if append-zero "0")
+ scaled-exp-str)))
+ (recur [rounded-mantissa (inc exp)]))))
+ navigator))
+
+;; the function to render ~G directives
+;; This just figures out whether to pass the request off to ~F or ~E based
+;; on the algorithm in CLtL.
+;; TODO: support rationals. Back off to ~D/~A is the appropriate cases
+;; TODO: refactor so that float-parts isn't called twice
+(defn- general-float [params navigator offsets]
+ (let [[arg _] (next-arg navigator)
+ [mantissa exp] (float-parts (if (neg? arg) (- arg) arg))
+ w (:w params)
+ d (:d params)
+ e (:e params)
+ n (if (= arg 0.0) 0 (inc exp))
+ ee (if e (+ e 2) 4)
+ ww (if w (- w ee))
+ d (if d d (max (count mantissa) (min n 7)))
+ dd (- d n)]
+ (if (<= 0 dd d)
+ (let [navigator (fixed-float {:w ww, :d dd, :k 0,
+ :overflowchar (:overflowchar params),
+ :padchar (:padchar params), :at (:at params)}
+ navigator offsets)]
+ (print (apply str (repeat ee \space)))
+ navigator)
+ (exponential-float params navigator offsets))))
+
+;; the function to render ~$ directives
+;; TODO: support rationals. Back off to ~D/~A is the appropriate cases
+(defn- dollar-float [params navigator offsets]
+ (let [[^Double arg navigator] (next-arg navigator)
+ [mantissa exp] (float-parts (Math/Abs arg)) ;;; Math/abs
+ d (:d params) ; digits after the decimal
+ n (:n params) ; minimum digits before the decimal
+ w (:w params) ; minimum field width
+ add-sign (or (:at params) (neg? arg))
+ [rounded-mantissa scaled-exp expanded] (round-str mantissa exp d nil)
+ ^String fixed-repr (get-fixed rounded-mantissa (if expanded (inc scaled-exp) scaled-exp) d)
+ full-repr (str (apply str (repeat (- n (.IndexOf fixed-repr \.)) \0)) fixed-repr) ;;; .indexOf (int \.)
+ full-len (+ (count full-repr) (if add-sign 1 0))]
+ (print (str
+ (if (and (:colon params) add-sign) (if (neg? arg) \- \+))
+ (apply str (repeat (- w full-len) (:padchar params)))
+ (if (and (not (:colon params)) add-sign) (if (neg? arg) \- \+))
+ full-repr))
+ navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for the '~[...~]' conditional construct in its
+;;; different flavors
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; ~[...~] without any modifiers chooses one of the clauses based on the param or
+;; next argument
+;; TODO check arg is positive int
+(defn- choice-conditional [params arg-navigator offsets]
+ (let [arg (:selector params)
+ [arg navigator] (if arg [arg arg-navigator] (next-arg arg-navigator))
+ clauses (:clauses params)
+ clause (if (or (neg? arg) (>= arg (count clauses)))
+ (first (:else params))
+ (nth clauses arg))]
+ (if clause
+ (execute-sub-format clause navigator (:base-args params))
+ navigator)))
+
+;; ~:[...~] with the colon reads the next argument treating it as a truth value
+(defn- boolean-conditional [params arg-navigator offsets]
+ (let [[arg navigator] (next-arg arg-navigator)
+ clauses (:clauses params)
+ clause (if arg
+ (second clauses)
+ (first clauses))]
+ (if clause
+ (execute-sub-format clause navigator (:base-args params))
+ navigator)))
+
+;; ~@[...~] with the at sign executes the conditional if the next arg is not
+;; nil/false without consuming the arg
+(defn- check-arg-conditional [params arg-navigator offsets]
+ (let [[arg navigator] (next-arg arg-navigator)
+ clauses (:clauses params)
+ clause (if arg (first clauses))]
+ (if arg
+ (if clause
+ (execute-sub-format clause arg-navigator (:base-args params))
+ arg-navigator)
+ navigator)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for the '~{...~}' iteration construct in its
+;;; different flavors
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;; ~{...~} without any modifiers uses the next argument as an argument list that
+;; is consumed by all the iterations
+(defn- iterate-sublist [params navigator offsets]
+ (let [max-count (:max-iterations params)
+ param-clause (first (:clauses params))
+ [clause navigator] (if (empty? param-clause)
+ (get-format-arg navigator)
+ [param-clause navigator])
+ [arg-list navigator] (next-arg navigator)
+ args (init-navigator arg-list)]
+ (loop [count 0
+ args args
+ last-pos -1]
+ (if (and (not max-count) (= (:pos args) last-pos) (> count 1))
+ ;; TODO get the offset in here and call format exception
+ (throw (Exception. "%{ construct not consuming any arguments: Infinite loop!"))) ;;; RuntimeException
+ (if (or (and (empty? (:rest args))
+ (or (not (:colon (:right-params params))) (> count 0)))
+ (and max-count (>= count max-count)))
+ navigator
+ (let [iter-result (execute-sub-format clause args (:base-args params))]
+ (if (= :up-arrow (first iter-result))
+ navigator
+ (recur (inc count) iter-result (:pos args))))))))
+
+;; ~:{...~} with the colon treats the next argument as a list of sublists. Each of the
+;; sublists is used as the arglist for a single iteration.
+(defn- iterate-list-of-sublists [params navigator offsets]
+ (let [max-count (:max-iterations params)
+ param-clause (first (:clauses params))
+ [clause navigator] (if (empty? param-clause)
+ (get-format-arg navigator)
+ [param-clause navigator])
+ [arg-list navigator] (next-arg navigator)]
+ (loop [count 0
+ arg-list arg-list]
+ (if (or (and (empty? arg-list)
+ (or (not (:colon (:right-params params))) (> count 0)))
+ (and max-count (>= count max-count)))
+ navigator
+ (let [iter-result (execute-sub-format
+ clause
+ (init-navigator (first arg-list))
+ (init-navigator (next arg-list)))]
+ (if (= :colon-up-arrow (first iter-result))
+ navigator
+ (recur (inc count) (next arg-list))))))))
+
+;; ~@{...~} with the at sign uses the main argument list as the arguments to the iterations
+;; is consumed by all the iterations
+(defn- iterate-main-list [params navigator offsets]
+ (let [max-count (:max-iterations params)
+ param-clause (first (:clauses params))
+ [clause navigator] (if (empty? param-clause)
+ (get-format-arg navigator)
+ [param-clause navigator])]
+ (loop [count 0
+ navigator navigator
+ last-pos -1]
+ (if (and (not max-count) (= (:pos navigator) last-pos) (> count 1))
+ ;; TODO get the offset in here and call format exception
+ (throw (Exception. "%@{ construct not consuming any arguments: Infinite loop!"))) ;;; RuntimeException
+ (if (or (and (empty? (:rest navigator))
+ (or (not (:colon (:right-params params))) (> count 0)))
+ (and max-count (>= count max-count)))
+ navigator
+ (let [iter-result (execute-sub-format clause navigator (:base-args params))]
+ (if (= :up-arrow (first iter-result))
+ (second iter-result)
+ (recur
+ (inc count) iter-result (:pos navigator))))))))
+
+;; ~@:{...~} with both colon and at sign uses the main argument list as a set of sublists, one
+;; of which is consumed with each iteration
+(defn- iterate-main-sublists [params navigator offsets]
+ (let [max-count (:max-iterations params)
+ param-clause (first (:clauses params))
+ [clause navigator] (if (empty? param-clause)
+ (get-format-arg navigator)
+ [param-clause navigator])
+ ]
+ (loop [count 0
+ navigator navigator]
+ (if (or (and (empty? (:rest navigator))
+ (or (not (:colon (:right-params params))) (> count 0)))
+ (and max-count (>= count max-count)))
+ navigator
+ (let [[sublist navigator] (next-arg-or-nil navigator)
+ iter-result (execute-sub-format clause (init-navigator sublist) navigator)]
+ (if (= :colon-up-arrow (first iter-result))
+ navigator
+ (recur (inc count) navigator)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The '~< directive has two completely different meanings
+;;; in the '~<...~>' form it does justification, but with
+;;; ~<...~:>' it represents the logical block operation of the
+;;; pretty printer.
+;;;
+;;; Unfortunately, the current architecture decides what function
+;;; to call at form parsing time before the sub-clauses have been
+;;; folded, so it is left to run-time to make the decision.
+;;;
+;;; TODO: make it possible to make these decisions at compile-time.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare format-logical-block)
+(declare justify-clauses)
+
+(defn- logical-block-or-justify [params navigator offsets]
+ (if (:colon (:right-params params))
+ (format-logical-block params navigator offsets)
+ (justify-clauses params navigator offsets)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for the '~<...~>' justification directive
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- render-clauses [clauses navigator base-navigator]
+ (loop [clauses clauses
+ acc []
+ navigator navigator]
+ (if (empty? clauses)
+ [acc navigator]
+ (let [clause (first clauses)
+ [iter-result result-str] (binding [*out* (System.IO.StringWriter.)] ;;; java.io.StringWriter.
+ [(execute-sub-format clause navigator base-navigator)
+ (.ToString *out*)])] ;;; toString
+ (if (= :up-arrow (first iter-result))
+ [acc (second iter-result)]
+ (recur (next clauses) (conj acc result-str) iter-result))))))
+
+;; TODO support for ~:; constructions
+(defn- justify-clauses [params navigator offsets]
+ (let [[[eol-str] new-navigator] (when-let [else (:else params)]
+ (render-clauses else navigator (:base-args params)))
+ navigator (or new-navigator navigator)
+ [else-params new-navigator] (when-let [p (:else-params params)]
+ (realize-parameter-list p navigator))
+ navigator (or new-navigator navigator)
+ min-remaining (or (first (:min-remaining else-params)) 0)
+ max-columns (or (first (:max-columns else-params))
+ (get-max-column *out*))
+ clauses (:clauses params)
+ [strs navigator] (render-clauses clauses navigator (:base-args params))
+ slots (max 1
+ (+ (dec (count strs)) (if (:colon params) 1 0) (if (:at params) 1 0)))
+ chars (reduce + (map count strs))
+ mincol (:mincol params)
+ minpad (:minpad params)
+ colinc (:colinc params)
+ minout (+ chars (* slots minpad))
+ result-columns (if (<= minout mincol)
+ mincol
+ (+ mincol (* colinc
+ (+ 1 (quot (- minout mincol 1) colinc)))))
+ total-pad (- result-columns chars)
+ pad (max minpad (quot total-pad slots))
+ extra-pad (- total-pad (* pad slots))
+ pad-str (apply str (repeat pad (:padchar params)))]
+ (if (and eol-str (> (+ (get-column (:base @@*out*)) min-remaining result-columns)
+ max-columns))
+ (print eol-str))
+ (loop [slots slots
+ extra-pad extra-pad
+ strs strs
+ pad-only (or (:colon params)
+ (and (= (count strs) 1) (not (:at params))))]
+ (if (seq strs)
+ (do
+ (print (str (if (not pad-only) (first strs))
+ (if (or pad-only (next strs) (:at params)) pad-str)
+ (if (pos? extra-pad) (:padchar params))))
+ (recur
+ (dec slots)
+ (dec extra-pad)
+ (if pad-only strs (next strs))
+ false))))
+ navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for case modification with ~(...~).
+;;; We do this by wrapping the underlying writer with
+;;; a special writer to do the appropriate modification. This
+;;; allows us to support arbitrary-sized output and sources
+;;; that may block.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- downcase-writer
+ "Returns a proxy that wraps writer, converting all characters to lower case"
+ [^System.IO.TextWriter writer] ;;; java.io.Writer
+ (proxy [System.IO.TextWriter] [] ;;; java.io.Writer
+ (Close [] (.Close writer)) ;;; close
+ (Flush [] (.Flush writer)) ;;; flush
+ (Write ([^chars cbuf ^Int32 off ^Int32 len] ;;; write Integer
+ (.Write writer cbuf off len)) ;;; write
+ ([x]
+ (condp = (class x)
+ String
+ (let [s ^String x]
+ (.Write writer (.ToLower s))) ;;; write toLowerCase
+
+ Int32 ;;; Integer
+ (let [c ^Char x] ;;; Character
+ (.Write writer (int (Char/ToLower (char c)))))))))) ;;; .write Character/toLowerCase
+
+(defn- upcase-writer
+ "Returns a proxy that wraps writer, converting all characters to upper case"
+ [^System.IO.TextWriter writer] ;;; java.io.Writer
+ (proxy [System.IO.TextWriter] [] ;;; java.io.Writer
+ (Close [] (.Close writer))
+ (Flush [] (.Flush writer))
+ (Write ([^chars cbuf ^Int32 off ^Int32 len]
+ (.Write writer cbuf off len))
+ ([x]
+ (condp = (class x)
+ String
+ (let [s ^String x]
+ (.Write writer (.ToUpper s)))
+
+ Int32
+ (let [c ^Char x]
+ (.Write writer (int (Char/ToUpper (char c))))))))))
+
+(defn- capitalize-string
+ "Capitalizes the words in a string. If first? is false, don't capitalize the
+ first character of the string even if it's a letter."
+ [s first?]
+ (let [^Char f (first s) ;;; Character
+ s (if (and first? f (Char/IsLetter f)) ;;; Character/isLetter
+ (str (Char/ToUpper f) (subs s 1)) ;;; Character/toUpperCase
+ s)]
+ (apply str
+ (first
+ (consume
+ (fn [s]
+ (if (empty? s)
+ [nil nil]
+ (let [m (re-matcher #"\W\w" s)
+ match (re-find m)
+ offset (and match (inc (.start m)))] ;;; .start
+ (if offset
+ [(str (subs s 0 offset)
+ (Char/ToUpper ^Char (nth s offset))) ;;; Character/toUpperCase Character
+ (subs s (inc offset))]
+ [s nil]))))
+ s)))))
+
+(defn- capitalize-word-writer
+ "Returns a proxy that wraps writer, captializing all words"
+ [^System.IO.TextWriter writer] ;;; java.io.Writer
+ (let [last-was-whitespace? (ref true)]
+ (proxy [System.IO.TextWriter] []
+ (Close [] (.Close writer))
+ (Flush [] (.Flush writer))
+ (Write
+ ([^chars cbuf ^Int32 off ^Int32 len]
+ (.Write writer cbuf off len))
+ ([x]
+ (condp = (class x)
+ String
+ (let [s ^String x]
+ (.Write writer
+ ^String (capitalize-string (.ToLower s) @last-was-whitespace?)) ;;; toLowerCase
+ (dosync
+ (ref-set last-was-whitespace?
+ (Char/IsWhiteSpace
+ ^Char (nth s (dec (count s)))))))
+
+ Int32
+ (let [c (char x)]
+ (let [mod-c (if @last-was-whitespace? (Char/ToUpper ^Char (char x)) c)]
+ (.Write writer (int mod-c))
+ (dosync (ref-set last-was-whitespace? (Char/IsWhiteSpace ^Char (char x))))))))))))
+
+(defn- init-cap-writer
+ "Returns a proxy that wraps writer, capitalizing the first word"
+ [^System.IO.TextWriter writer] ;;; java.io.Writer
+ (let [capped (ref false)]
+ (proxy [System.IO.TextWriter] []
+ (Close [] (.Close writer))
+ (Flush [] (.Flush writer))
+ (Write ([^chars cbuf ^Int32 off ^Int32 len]
+ (.Write writer cbuf off len))
+ ([x]
+ (condp = (class x)
+ String
+ (let [s (.ToLower ^String x)]
+ (if (not @capped)
+ (let [m (re-matcher #"\S" s)
+ match (re-find m)
+ offset (and match (.start m))] ;;; start
+ (if offset
+ (do (.Write writer
+ (str (subs s 0 offset)
+ (Char/ToUpper ^Char (nth s offset))
+ (.ToLower ^String (subs s (inc offset)))))
+ (dosync (ref-set capped true)))
+ (.Write writer s)))
+ (.Write writer (.ToLower s))))
+
+ Int32
+ (let [c ^Char (char x)]
+ (if (and (not @capped) (Char/IsLetter c))
+ (do
+ (dosync (ref-set capped true))
+ (.Write writer (int (Char/ToUpper c))))
+ (.Write writer (int (Char/ToLower c)))))))))))
+
+(defn- modify-case [make-writer params navigator offsets]
+ (let [clause (first (:clauses params))]
+ (binding [*out* (make-writer *out*)]
+ (execute-sub-format clause navigator (:base-args params)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; If necessary, wrap the writer in a PrettyWriter object
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn get-pretty-writer
+ "Returns the java.io.Writer passed in wrapped in a pretty writer proxy, unless it's
+already a pretty writer. Generally, it is unneccesary to call this function, since pprint,
+write, and cl-format all call it if they need to. However if you want the state to be
+preserved across calls, you will want to wrap them with this.
+
+For example, when you want to generate column-aware output with multiple calls to cl-format,
+do it like in this example:
+
+ (defn print-table [aseq column-width]
+ (binding [*out* (get-pretty-writer *out*)]
+ (doseq [row aseq]
+ (doseq [col row]
+ (cl-format true \"~4D~7,vT\" col column-width))
+ (prn))))
+
+Now when you run:
+
+ user> (print-table (map #(vector % (* % %) (* % % %)) (range 1 11)) 8)
+
+It prints a table of squares and cubes for the numbers from 1 to 10:
+
+ 1 1 1
+ 2 4 8
+ 3 9 27
+ 4 16 64
+ 5 25 125
+ 6 36 216
+ 7 49 343
+ 8 64 512
+ 9 81 729
+ 10 100 1000"
+ {:added "1.2"}
+ [writer]
+ (if (pretty-writer? writer)
+ writer
+ (pretty-writer writer *print-right-margin* *print-miser-width*)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for column-aware operations ~&, ~T
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn fresh-line
+ "Make a newline if *out* is not already at the beginning of the line. If *out* is
+not a pretty writer (which keeps track of columns), this function always outputs a newline."
+ {:added "1.2"}
+ []
+ (if (instance? clojure.lang.IDeref *out*)
+ (if (not (= 0 (get-column (:base @@*out*))))
+ (prn))
+ (prn)))
+
+(defn- absolute-tabulation [params navigator offsets]
+ (let [colnum (:colnum params)
+ colinc (:colinc params)
+ current (get-column (:base @@*out*))
+ space-count (cond
+ (< current colnum) (- colnum current)
+ (= colinc 0) 0
+ :else (- colinc (rem (- current colnum) colinc)))]
+ (print (apply str (repeat space-count \space))))
+ navigator)
+
+(defn- relative-tabulation [params navigator offsets]
+ (let [colrel (:colnum params)
+ colinc (:colinc params)
+ start-col (+ colrel (get-column (:base @@*out*)))
+ offset (if (pos? colinc) (rem start-col colinc) 0)
+ space-count (+ colrel (if (= 0 offset) 0 (- colinc offset)))]
+ (print (apply str (repeat space-count \space))))
+ navigator)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Support for accessing the pretty printer from a format
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; TODO: support ~@; per-line-prefix separator
+;; TODO: get the whole format wrapped so we can start the lb at any column
+(defn- format-logical-block [params navigator offsets]
+ (let [clauses (:clauses params)
+ clause-count (count clauses)
+ prefix (cond
+ (> clause-count 1) (:string (:params (first (first clauses))))
+ (:colon params) "(")
+ body (nth clauses (if (> clause-count 1) 1 0))
+ suffix (cond
+ (> clause-count 2) (:string (:params (first (nth clauses 2))))
+ (:colon params) ")")
+ [arg navigator] (next-arg navigator)]
+ (pprint-logical-block :prefix prefix :suffix suffix
+ (execute-sub-format
+ body
+ (init-navigator arg)
+ (:base-args params)))
+ navigator))
+
+(defn- set-indent [params navigator offsets]
+ (let [relative-to (if (:colon params) :current :block)]
+ (pprint-indent relative-to (:n params))
+ navigator))
+
+;;; TODO: support ~:T section options for ~T
+
+(defn- conditional-newline [params navigator offsets]
+ (let [kind (if (:colon params)
+ (if (:at params) :mandatory :fill)
+ (if (:at params) :miser :linear))]
+ (pprint-newline kind)
+ navigator))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The table of directives we support, each with its params,
+;;; properties, and the compilation function
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; We start with a couple of helpers
+(defn- process-directive-table-element [ [ char params flags bracket-info & generator-fn ] ]
+ [char,
+ {:directive char,
+ :params `(array-map ~@params),
+ :flags flags,
+ :bracket-info bracket-info,
+ :generator-fn (concat '(fn [ params offset]) generator-fn) }])
+
+(defmacro ^{:private true}
+ defdirectives
+ [ & directives ]
+ `(def ^{:private true}
+ directive-table (hash-map ~@(mapcat process-directive-table-element directives))))
+
+(defdirectives
+ (\A
+ [ :mincol [0 Int32] :colinc [1 Int32] :minpad [0 Int32] :padchar [\space Char] ]
+ #{ :at :colon :both} {}
+ #(format-ascii print-str %1 %2 %3))
+
+ (\S
+ [ :mincol [0 Int32] :colinc [1 Int32] :minpad [0 Int32] :padchar [\space Char] ]
+ #{ :at :colon :both} {}
+ #(format-ascii pr-str %1 %2 %3))
+
+ (\D
+ [ :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char]
+ :commainterval [ 3 Int32]]
+ #{ :at :colon :both } {}
+ #(format-integer 10 %1 %2 %3))
+
+ (\B
+ [ :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char]
+ :commainterval [ 3 Int32]]
+ #{ :at :colon :both } {}
+ #(format-integer 2 %1 %2 %3))
+
+ (\O
+ [ :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char]
+ :commainterval [ 3 Int32]]
+ #{ :at :colon :both } {}
+ #(format-integer 8 %1 %2 %3))
+
+ (\X
+ [ :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char]
+ :commainterval [ 3 Int32]]
+ #{ :at :colon :both } {}
+ #(format-integer 16 %1 %2 %3))
+
+ (\R
+ [:base [nil Int32] :mincol [0 Int32] :padchar [\space Char] :commachar [\, Char]
+ :commainterval [ 3 Int32]]
+ #{ :at :colon :both } {}
+ (do
+ (cond ; ~R is overloaded with bizareness
+ (first (:base params)) #(format-integer (:base %1) %1 %2 %3)
+ (and (:at params) (:colon params)) #(format-old-roman %1 %2 %3)
+ (:at params) #(format-new-roman %1 %2 %3)
+ (:colon params) #(format-ordinal-english %1 %2 %3)
+ true #(format-cardinal-english %1 %2 %3))))
+
+ (\P
+ [ ]
+ #{ :at :colon :both } {}
+ (fn [params navigator offsets]
+ (let [navigator (if (:colon params) (relative-reposition navigator -1) navigator)
+ strs (if (:at params) ["y" "ies"] ["" "s"])
+ [arg navigator] (next-arg navigator)]
+ (print (if (= arg 1) (first strs) (second strs)))
+ navigator)))
+
+ (\C
+ [:char-format [nil Char]]
+ #{ :at :colon :both } {}
+ (cond
+ (:colon params) pretty-character
+ (:at params) readable-character
+ :else plain-character))
+
+ (\F
+ [ :w [nil Int32] :d [nil Int32] :k [0 Int32] :overflowchar [nil Char]
+ :padchar [\space Char] ]
+ #{ :at } {}
+ fixed-float)
+
+ (\E
+ [ :w [nil Int32] :d [nil Int32] :e [nil Int32] :k [1 Int32]
+ :overflowchar [nil Char] :padchar [\space Char]
+ :exponentchar [nil Char] ]
+ #{ :at } {}
+ exponential-float)
+
+ (\G
+ [ :w [nil Int32] :d [nil Int32] :e [nil Int32] :k [1 Int32]
+ :overflowchar [nil Char] :padchar [\space Char]
+ :exponentchar [nil Char] ]
+ #{ :at } {}
+ general-float)
+
+ (\$
+ [ :d [2 Int32] :n [1 Int32] :w [0 Int32] :padchar [\space Char]]
+ #{ :at :colon :both} {}
+ dollar-float)
+
+ (\%
+ [ :count [1 Int32] ]
+ #{ } {}
+ (fn [params arg-navigator offsets]
+ (dotimes [i (:count params)]
+ (prn))
+ arg-navigator))
+
+ (\&
+ [ :count [1 Int32] ]
+ #{ :pretty } {}
+ (fn [params arg-navigator offsets]
+ (let [cnt (:count params)]
+ (if (pos? cnt) (fresh-line))
+ (dotimes [i (dec cnt)]
+ (prn)))
+ arg-navigator))
+
+ (\|
+ [ :count [1 Int32] ]
+ #{ } {}
+ (fn [params arg-navigator offsets]
+ (dotimes [i (:count params)]
+ (print \formfeed))
+ arg-navigator))
+
+ (\~
+ [ :n [1 Int32] ]
+ #{ } {}
+ (fn [params arg-navigator offsets]
+ (let [n (:n params)]
+ (print (apply str (repeat n \~)))
+ arg-navigator)))
+
+ (\newline ;; Whitespace supression is handled in the compilation loop
+ [ ]
+ #{:colon :at} {}
+ (fn [params arg-navigator offsets]
+ (if (:at params)
+ (prn))
+ arg-navigator))
+
+ (\T
+ [ :colnum [1 Int32] :colinc [1 Int32] ]
+ #{ :at :pretty } {}
+ (if (:at params)
+ #(relative-tabulation %1 %2 %3)
+ #(absolute-tabulation %1 %2 %3)))
+
+ (\*
+ [ :n [1 Int32] ]
+ #{ :colon :at } {}
+ (fn [params navigator offsets]
+ (let [n (:n params)]
+ (if (:at params)
+ (absolute-reposition navigator n)
+ (relative-reposition navigator (if (:colon params) (- n) n)))
+ )))
+
+ (\?
+ [ ]
+ #{ :at } {}
+ (if (:at params)
+ (fn [params navigator offsets] ; args from main arg list
+ (let [[subformat navigator] (get-format-arg navigator)]
+ (execute-sub-format subformat navigator (:base-args params))))
+ (fn [params navigator offsets] ; args from sub-list
+ (let [[subformat navigator] (get-format-arg navigator)
+ [subargs navigator] (next-arg navigator)
+ sub-navigator (init-navigator subargs)]
+ (execute-sub-format subformat sub-navigator (:base-args params))
+ navigator))))
+
+
+ (\(
+ [ ]
+ #{ :colon :at :both} { :right \), :allows-separator nil, :else nil }
+ (let [mod-case-writer (cond
+ (and (:at params) (:colon params))
+ upcase-writer
+
+ (:colon params)
+ capitalize-word-writer
+
+ (:at params)
+ init-cap-writer
+
+ :else
+ downcase-writer)]
+ #(modify-case mod-case-writer %1 %2 %3)))
+
+ (\) [] #{} {} nil)
+
+ (\[
+ [ :selector [nil Int32] ]
+ #{ :colon :at } { :right \], :allows-separator true, :else :last }
+ (cond
+ (:colon params)
+ boolean-conditional
+
+ (:at params)
+ check-arg-conditional
+
+ true
+ choice-conditional))
+
+ (\; [:min-remaining [nil Int32] :max-columns [nil Int32]]
+ #{ :colon } { :separator true } nil)
+
+ (\] [] #{} {} nil)
+
+ (\{
+ [ :max-iterations [nil Int32] ]
+ #{ :colon :at :both} { :right \}, :allows-separator false }
+ (cond
+ (and (:at params) (:colon params))
+ iterate-main-sublists
+
+ (:colon params)
+ iterate-list-of-sublists
+
+ (:at params)
+ iterate-main-list
+
+ true
+ iterate-sublist))
+
+
+ (\} [] #{:colon} {} nil)
+
+ (\<
+ [:mincol [0 Int32] :colinc [1 Int32] :minpad [0 Int32] :padchar [\space Char]]
+ #{:colon :at :both :pretty} { :right \>, :allows-separator true, :else :first }
+ logical-block-or-justify)
+
+ (\> [] #{:colon} {} nil)
+
+ ;; TODO: detect errors in cases where colon not allowed
+ (\^ [:arg1 [nil Int32] :arg2 [nil Int32] :arg3 [nil Int32]]
+ #{:colon} {}
+ (fn [params navigator offsets]
+ (let [arg1 (:arg1 params)
+ arg2 (:arg2 params)
+ arg3 (:arg3 params)
+ exit (if (:colon params) :colon-up-arrow :up-arrow)]
+ (cond
+ (and arg1 arg2 arg3)
+ (if (<= arg1 arg2 arg3) [exit navigator] navigator)
+
+ (and arg1 arg2)
+ (if (= arg1 arg2) [exit navigator] navigator)
+
+ arg1
+ (if (= arg1 0) [exit navigator] navigator)
+
+ true ; TODO: handle looking up the arglist stack for info
+ (if (if (:colon params)
+ (empty? (:rest (:base-args params)))
+ (empty? (:rest navigator)))
+ [exit navigator] navigator)))))
+
+ (\W
+ []
+ #{:at :colon :both} {}
+ (if (or (:at params) (:colon params))
+ (let [bindings (concat
+ (if (:at params) [:level nil :length nil] [])
+ (if (:colon params) [:pretty true] []))]
+ (fn [params navigator offsets]
+ (let [[arg navigator] (next-arg navigator)]
+ (if (apply write arg bindings)
+ [:up-arrow navigator]
+ navigator))))
+ (fn [params navigator offsets]
+ (let [[arg navigator] (next-arg navigator)]
+ (if (write-out arg)
+ [:up-arrow navigator]
+ navigator)))))
+
+ (\_
+ []
+ #{:at :colon :both} {}
+ conditional-newline)
+
+ (\I
+ [:n [0 Int32]]
+ #{:colon} {}
+ set-indent)
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Code to manage the parameters and flags associated with each
+;;; directive in the format string.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true}
+ param-pattern #"^([vV]|#|('.)|([+-]?\d+)|(?=,))")
+(def ^{:private true}
+ special-params #{ :parameter-from-args :remaining-arg-count })
+
+(defn- extract-param [[s offset saw-comma]]
+ (let [m (re-matcher param-pattern s)
+ param (re-find m)]
+ (if param
+ (let [token-str (first (re-groups m))
+ remainder (subs s (.end m)) ;;; end
+ new-offset (+ offset (.end m))]
+ (if (not (= \, (nth remainder 0)))
+ [ [token-str offset] [remainder new-offset false]]
+ [ [token-str offset] [(subs remainder 1) (inc new-offset) true]]))
+ (if saw-comma
+ (format-error "Badly formed parameters in format directive" offset)
+ [ nil [s offset]]))))
+
+
+(defn- extract-params [s offset]
+ (consume extract-param [s offset false]))
+
+(defn- translate-param
+ "Translate the string representation of a param to the internalized
+ representation"
+ [[^String p offset]]
+ [(cond
+ (= (.Length p) 0) nil
+ (and (= (.Length p) 1) (contains? #{\v \V} (nth p 0))) :parameter-from-args ;;; length
+ (and (= (.Length p) 1) (= \# (nth p 0))) :remaining-arg-count
+ (and (= (.Length p) 2) (= \' (nth p 0))) (nth p 1)
+ true (Int32/Parse p)) ;;; (new Integer p)
+ offset])
+
+(def ^{:private true}
+ flag-defs { \: :colon, \@ :at })
+
+(defn- extract-flags [s offset]
+ (consume
+ (fn [[s offset flags]]
+ (if (empty? s)
+ [nil [s offset flags]]
+ (let [flag (get flag-defs (first s))]
+ (if flag
+ (if (contains? flags flag)
+ (format-error
+ (str "Flag \"" (first s) "\" appears more than once in a directive")
+ offset)
+ [true [(subs s 1) (inc offset) (assoc flags flag [true offset])]])
+ [nil [s offset flags]]))))
+ [s offset {}]))
+
+(defn- check-flags [def flags]
+ (let [allowed (:flags def)]
+ (if (and (not (:at allowed)) (:at flags))
+ (format-error (str "\"@\" is an illegal flag for format directive \"" (:directive def) "\"")
+ (nth (:at flags) 1)))
+ (if (and (not (:colon allowed)) (:colon flags))
+ (format-error (str "\":\" is an illegal flag for format directive \"" (:directive def) "\"")
+ (nth (:colon flags) 1)))
+ (if (and (not (:both allowed)) (:at flags) (:colon flags))
+ (format-error (str "Cannot combine \"@\" and \":\" flags for format directive \""
+ (:directive def) "\"")
+ (min (nth (:colon flags) 1) (nth (:at flags) 1))))))
+
+(defn- map-params
+ "Takes a directive definition and the list of actual parameters and
+a map of flags and returns a map of the parameters and flags with defaults
+filled in. We check to make sure that there are the right types and number
+of parameters as well."
+ [def params flags offset]
+ (check-flags def flags)
+ (if (> (count params) (count (:params def)))
+ (format-error
+ (cl-format
+ nil
+ "Too many parameters for directive \"~C\": ~D~:* ~[were~;was~:;were~] specified but only ~D~:* ~[are~;is~:;are~] allowed"
+ (:directive def) (count params) (count (:params def)))
+ (second (first params))))
+ (doall
+ (map #(let [val (first %1)]
+ (if (not (or (nil? val) (contains? special-params val)
+ (instance? (second (second %2)) val)))
+ (format-error (str "Parameter " (name (first %2))
+ " has bad type in directive \"" (:directive def) "\": "
+ (class val))
+ (second %1))) )
+ params (:params def)))
+
+ (merge ; create the result map
+ (into (array-map) ; start with the default values, make sure the order is right
+ (reverse (for [[name [default]] (:params def)] [name [default offset]])))
+ (reduce #(apply assoc %1 %2) {} (filter #(first (nth % 1)) (zipmap (keys (:params def)) params))) ; add the specified parameters, filtering out nils
+ flags)) ; and finally add the flags
+
+(defn- compile-directive [s offset]
+ (let [[raw-params [rest offset]] (extract-params s offset)
+ [_ [rest offset flags]] (extract-flags rest offset)
+ directive (first rest)
+ def (get directive-table (Char/ToUpper ^Char directive)) ;;; Character/toUpperCase
+ params (if def (map-params def (map translate-param raw-params) flags offset))]
+ (if (not directive)
+ (format-error "Format string ended in the middle of a directive" offset))
+ (if (not def)
+ (format-error (str "Directive \"" directive "\" is undefined") offset))
+ [(struct compiled-directive ((:generator-fn def) params offset) def params offset)
+ (let [remainder (subs rest 1)
+ offset (inc offset)
+ trim? (and (= \newline (:directive def))
+ (not (:colon params)))
+ trim-count (if trim? (prefix-count remainder [\space \tab]) 0)
+ remainder (subs remainder trim-count)
+ offset (+ offset trim-count)]
+ [remainder offset])]))
+
+(defn- compile-raw-string [s offset]
+ (struct compiled-directive (fn [_ a _] (print s) a) nil { :string s } offset))
+
+(defn- right-bracket [this] (:right (:bracket-info (:def this))))
+(defn- separator? [this] (:separator (:bracket-info (:def this))))
+(defn- else-separator? [this]
+ (and (:separator (:bracket-info (:def this)))
+ (:colon (:params this))))
+
+
+(declare collect-clauses)
+
+(defn- process-bracket [this remainder]
+ (let [[subex remainder] (collect-clauses (:bracket-info (:def this))
+ (:offset this) remainder)]
+ [(struct compiled-directive
+ (:func this) (:def this)
+ (merge (:params this) (tuple-map subex (:offset this)))
+ (:offset this))
+ remainder]))
+
+(defn- process-clause [bracket-info offset remainder]
+ (consume
+ (fn [remainder]
+ (if (empty? remainder)
+ (format-error "No closing bracket found." offset)
+ (let [this (first remainder)
+ remainder (next remainder)]
+ (cond
+ (right-bracket this)
+ (process-bracket this remainder)
+
+ (= (:right bracket-info) (:directive (:def this)))
+ [ nil [:right-bracket (:params this) nil remainder]]
+
+ (else-separator? this)
+ [nil [:else nil (:params this) remainder]]
+
+ (separator? this)
+ [nil [:separator nil nil remainder]] ;; TODO: check to make sure that there are no params on ~;
+
+ true
+ [this remainder]))))
+ remainder))
+
+(defn- collect-clauses [bracket-info offset remainder]
+ (second
+ (consume
+ (fn [[clause-map saw-else remainder]]
+ (let [[clause [type right-params else-params remainder]]
+ (process-clause bracket-info offset remainder)]
+ (cond
+ (= type :right-bracket)
+ [nil [(merge-with concat clause-map
+ {(if saw-else :else :clauses) [clause]
+ :right-params right-params})
+ remainder]]
+
+ (= type :else)
+ (cond
+ (:else clause-map)
+ (format-error "Two else clauses (\"~:;\") inside bracket construction." offset)
+
+ (not (:else bracket-info))
+ (format-error "An else clause (\"~:;\") is in a bracket type that doesn't support it."
+ offset)
+
+ (and (= :first (:else bracket-info)) (seq (:clauses clause-map)))
+ (format-error
+ "The else clause (\"~:;\") is only allowed in the first position for this directive."
+ offset)
+
+ true ; if the ~:; is in the last position, the else clause
+ ; is next, this was a regular clause
+ (if (= :first (:else bracket-info))
+ [true [(merge-with concat clause-map { :else [clause] :else-params else-params})
+ false remainder]]
+ [true [(merge-with concat clause-map { :clauses [clause] })
+ true remainder]]))
+
+ (= type :separator)
+ (cond
+ saw-else
+ (format-error "A plain clause (with \"~;\") follows an else clause (\"~:;\") inside bracket construction." offset)
+
+ (not (:allows-separator bracket-info))
+ (format-error "A separator (\"~;\") is in a bracket type that doesn't support it."
+ offset)
+
+ true
+ [true [(merge-with concat clause-map { :clauses [clause] })
+ false remainder]]))))
+ [{ :clauses [] } false remainder])))
+
+(defn- process-nesting
+ "Take a linearly compiled format and process the bracket directives to give it
+ the appropriate tree structure"
+ [format]
+ (first
+ (consume
+ (fn [remainder]
+ (let [this (first remainder)
+ remainder (next remainder)
+ bracket (:bracket-info (:def this))]
+ (if (:right bracket)
+ (process-bracket this remainder)
+ [this remainder])))
+ format)))
+
+(defn- compile-format
+ "Compiles format-str into a compiled format which can be used as an argument
+to cl-format just like a plain format string. Use this function for improved
+performance when you're using the same format string repeatedly"
+ [ format-str ]
+; (prlabel compiling format-str)
+ (binding [*format-str* format-str]
+ (process-nesting
+ (first
+ (consume
+ (fn [[^String s offset]]
+ (if (empty? s)
+ [nil s]
+ (let [tilde (.IndexOf s \~)] ;;; indexOf (int \~)
+ (cond
+ (neg? tilde) [(compile-raw-string s offset) ["" (+ offset (.Length s))]] ;;; length
+ (zero? tilde) (compile-directive (subs s 1) (inc offset))
+ true
+ [(compile-raw-string (subs s 0 tilde) offset) [(subs s tilde) (+ tilde offset)]]))))
+ [format-str 0])))))
+
+(defn- needs-pretty
+ "determine whether a given compiled format has any directives that depend on the
+column number or pretty printing"
+ [format]
+ (loop [format format]
+ (if (empty? format)
+ false
+ (if (or (:pretty (:flags (:def (first format))))
+ (some needs-pretty (first (:clauses (:params (first format)))))
+ (some needs-pretty (first (:else (:params (first format))))))
+ true
+ (recur (next format))))))
+
+(defn- execute-format
+ "Executes the format with the arguments."
+ {:skip-wiki true}
+ ([stream format args]
+ (let [^System.IO.TextWriter real-stream (cond ;;; java.io.Writer
+ (not stream) (System.IO.StringWriter.) ;;; java.io.StringWriter
+ (true? stream) *out*
+ :else stream)
+ ^System.IO.TextWriter wrapped-stream (if (and (needs-pretty format) ;;; java.io.Writer
+ (not (pretty-writer? real-stream)))
+ (get-pretty-writer real-stream)
+ real-stream)]
+ (binding [*out* wrapped-stream]
+ (try
+ (execute-format format args)
+ (finally
+ (if-not (identical? real-stream wrapped-stream)
+ (.Flush wrapped-stream)))) ;;; flush
+ (if (not stream) (.ToString real-stream))))) ;;; toString
+ ([format args]
+ (map-passing-context
+ (fn [element context]
+ (if (abort? context)
+ [nil context]
+ (let [[params args] (realize-parameter-list
+ (:params element) context)
+ [params offsets] (unzip-map params)
+ params (assoc params :base-args args)]
+ [nil (apply (:func element) [params args offsets])])))
+ args
+ format)
+ nil))
+
+;;; This is a bad idea, but it prevents us from leaking private symbols
+;;; This should all be replaced by really compiled formats anyway.
+(def ^{:private true} cached-compile (memoize compile-format))
+
+(defmacro formatter
+ "Makes a function which can directly run format-in. The function is
+fn [stream & args] ... and returns nil unless the stream is nil (meaning
+output to a string) in which case it returns the resulting string.
+
+format-in can be either a control string or a previously compiled format."
+ {:added "1.2"}
+ [format-in]
+ `(let [format-in# ~format-in
+ my-c-c# (var-get (get (ns-interns (the-ns 'clojure.pprint))
+ '~'cached-compile))
+ my-e-f# (var-get (get (ns-interns (the-ns 'clojure.pprint))
+ '~'execute-format))
+ my-i-n# (var-get (get (ns-interns (the-ns 'clojure.pprint))
+ '~'init-navigator))
+ cf# (if (string? format-in#) (my-c-c# format-in#) format-in#)]
+ (fn [stream# & args#]
+ (let [navigator# (my-i-n# args#)]
+ (my-e-f# stream# cf# navigator#)))))
+
+(defmacro formatter-out
+ "Makes a function which can directly run format-in. The function is
+fn [& args] ... and returns nil. This version of the formatter macro is
+designed to be used with *out* set to an appropriate Writer. In particular,
+this is meant to be used as part of a pretty printer dispatch method.
+
+format-in can be either a control string or a previously compiled format."
+ {:added "1.2"}
+ [format-in]
+ `(let [format-in# ~format-in
+ my-c-c# (var-get (get (ns-interns (the-ns 'clojure.pprint))
+ '~'cached-compile))
+ my-e-f# (var-get (get (ns-interns (the-ns 'clojure.pprint))
+ '~'execute-format))
+ my-i-n# (var-get (get (ns-interns (the-ns 'clojure.pprint))
+ '~'init-navigator))
+ cf# (if (string? format-in#) (my-c-c# format-in#) format-in#)]
+ (fn [& args#]
+ (let [navigator# (my-i-n# args#)]
+ (my-e-f# cf# navigator#)))))
View
79 Clojure/Clojure.Source/clojure/pprint/column_writer.clj
@@ -0,0 +1,79 @@
+;;; column_writer.clj -- part of the pretty printer for Clojure
+
+
+; Copyright (c) Rich Hickey. All rights reserved.
+; The use and distribution terms for this software are covered by the
+; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+; which can be found in the file epl-v10.html at the root of this distribution.
+; By using this software in any fashion, you are agreeing to be bound by
+; the terms of this license.
+; You must not remove this notice, or any other, from this software.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+;; Revised to use proxy instead of gen-class April 2010
+
+;; This module implements a column-aware wrapper around an instance of java.io.Writer
+
+(in-ns 'clojure.pprint)
+
+(import [clojure.lang IDeref]
+ [System.IO TextWriter]) ;;; java.io Writer All instances of Writer replaced by TextWriter
+
+(def ^{:private true} *default-page-width* 72)
+
+(defn- get-field [^TextWriter this sym]
+ (sym @@this))
+
+(defn- set-field [^TextWriter this sym new-val]
+ (alter @this assoc sym new-val))
+
+(defn- get-column [this]
+ (get-field this :cur))
+
+(defn- get-line [this]
+ (get-field this :line))
+
+(defn- get-max-column [this]
+ (get-field this :max))
+
+(defn- set-max-column [this new-max]
+ (dosync (set-field this :max new-max))
+ nil)
+
+(defn- get-writer [this]
+ (get-field this :base))
+
+(defn- c-write-char [^TextWriter this ^Int32 c]
+ (dosync (if (= c (int \newline))
+ (do
+ (set-field this :cur 0)
+ (set-field this :line (inc (get-field this :line))))
+ (set-field this :cur (inc (get-field this :cur)))))
+ (.Write ^TextWriter (get-field this :base) c))
+
+(defn- column-writer
+ ([writer] (column-writer writer *default-page-width*))
+ ([writer max-columns]
+ (let [fields (ref {:max max-columns, :cur 0, :line 0 :base writer})]
+ (proxy [TextWriter IDeref] []
+ (deref [] fields)
+ (Write
+ ([^chars cbuf ^Int32 off ^Int32 len]
+ (let [^TextWriter writer (get-field this :base)]
+ (.Write writer cbuf off len)))
+ ([x]
+ (condp = (class x)
+ String
+ (let [^String s x
+ nl (.LastIndexOf s (int \newline))]
+ (dosync (if (neg? nl)
+ (set-field this :cur (+ (get-field this :cur) (count s)))
+ (do
+ (set-field this :cur (- (count s) nl 1))
+ (set-field this :line (+ (get-field this :line)
+ (count (filter #(= % \newline) s)))))))
+ (.Write ^TextWriter (get-field this :base) s))
+
+ Int32
+ (c-write-char this x))))))))
View
448 Clojure/Clojure.Source/clojure/pprint/dispatch.clj
@@ -0,0 +1,448 @@
+;; dispatch.clj -- part of the pretty printer for Clojure
+
+; Copyright (c) Rich Hickey. All rights reserved.
+; The use and distribution terms for this software are covered by the
+; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+; which can be found in the file epl-v10.html at the root of this distribution.
+; By using this software in any fashion, you are agreeing to be bound by
+; the terms of this license.
+; You must not remove this notice, or any other, from this software.
+
+;; Author: Tom Faulhaber
+;; April 3, 2009
+
+
+;; This module implements the default dispatch tables for pretty printing code and
+;; data.
+
+(in-ns 'clojure.pprint)
+
+(defn- use-method
+ "Installs a function as a new method of multimethod associated with dispatch-value. "
+ [multifn dispatch-val func]
+ (. multifn addMethod dispatch-val func))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Implementations of specific dispatch table entries
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Handle forms that can be "back-translated" to reader macros
+;;; Not all reader macros can be dealt with this way or at all.
+;;; Macros that we can't deal with at all are:
+;;; ; - The comment character is aborbed by the reader and never is part of the form
+;;; ` - Is fully processed at read time into a lisp expression (which will contain concats
+;;; and regular quotes).
+;;; ~@ - Also fully eaten by the processing of ` and can't be used outside.
+;;; , - is whitespace and is lost (like all other whitespace). Formats can generate commas
+;;; where they deem them useful to help readability.
+;;; ^ - Adding metadata completely disappears at read time and the data appears to be
+;;; completely lost.
+;;;
+;;; Most other syntax stuff is dealt with directly by the formats (like (), [], {}, and #{})
+;;; or directly by printing the objects using Clojure's built-in print functions (like
+;;; :keyword, \char, or ""). The notable exception is #() which is special-cased.
+
+(def ^{:private true} reader-macros
+ {'quote "'", 'clojure.core/deref "@",
+ 'var "#'", 'clojure.core/unquote "~"})
+
+(defn- pprint-reader-macro [alis]
+ (let [^String macro-char (reader-macros (first alis))]
+ (when (and macro-char (= 2 (count alis)))
+ (.Write ^System.IO.TextWriter *out* macro-char)
+ (write-out (second alis))
+ true)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Dispatch for the basic data types when interpreted
+;; as data (as opposed to code).
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; TODO: inline these formatter statements into funcs so that we
+;;; are a little easier on the stack. (Or, do "real" compilation, a
+;;; la Common Lisp)
+
+;;; (def pprint-simple-list (formatter-out "~:<~@{~w~^ ~_~}~:>"))
+(defn- pprint-simple-list [alis]
+ (pprint-logical-block :prefix "(" :suffix ")"
+ (loop [alis (seq alis)]
+ (when alis
+ (write-out (first alis))
+ (when (next alis)
+ (.Write ^System.IO.TextWriter *out* " ")
+ (pprint-newline :linear)
+ (recur (next alis)))))))
+
+(defn- pprint-list [alis]
+ (if-not (pprint-reader-macro alis)
+ (pprint-simple-list alis)))
+
+;;; (def pprint-vector (formatter-out "~<[~;~@{~w~^ ~_~}~;]~:>"))
+(defn- pprint-vector [avec]
+ (pprint-logical-block :prefix "[" :suffix "]"
+ (loop [aseq (seq avec)]
+ (when aseq
+ (write-out (first aseq))
+ (when (next aseq)
+ (.Write ^System.IO.TextWriter *out* " ")
+ (pprint-newline :linear)
+ (recur (next aseq)))))))
+
+(def ^{:private true} pprint-array (formatter-out "~<[~;~@{~w~^, ~:_~}~;]~:>"))
+
+;;; (def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>"))
+(defn- pprint-map [amap]
+ (pprint-logical-block :prefix "{" :suffix "}"
+ (loop [aseq (seq amap)]
+ (when aseq
+ (pprint-logical-block
+ (write-out (ffirst aseq))
+ (.Write ^System.IO.TextWriter *out* " ")
+ (pprint-newline :linear)
+ (write-out (fnext (first aseq))))
+ (when (next aseq)
+ (.Write ^System.IO.TextWriter *out* ", ")
+ (pprint-newline :linear)
+ (recur (next aseq)))))))
+
+(def ^{:private true} pprint-set (formatter-out "~<#{~;~@{~w~^ ~:_~}~;}~:>"))
+(defn- pprint-ref [ref]
+ (pprint-logical-block :prefix "#<Ref " :suffix ">"
+ (write-out @ref)))
+(defn- pprint-atom [ref]
+ (pprint-logical-block :prefix "#<Atom " :suffix ">"
+ (write-out @ref)))
+(defn- pprint-agent [ref]
+ (pprint-logical-block :prefix "#<Agent " :suffix ">"
+ (write-out @ref)))
+
+(defn- pprint-simple-default [obj]
+ (cond
+ (.IsArray (class obj)) (pprint-array obj)
+ (and *print-suppress-namespaces* (symbol? obj)) (print (name obj))
+ :else (pr obj)))
+
+
+(defmulti
+ simple-dispatch
+ "The pretty print dispatch function for simple data structure format."
+ {:added "1.2" :arglists '[[object]]}
+ class)
+
+(use-method simple-dispatch clojure.lang.ISeq pprint-list)
+(use-method simple-dispatch clojure.lang.IPersistentVector pprint-vector)
+(use-method simple-dispatch clojure.lang.IPersistentMap pprint-map)
+(use-method simple-dispatch clojure.lang.IPersistentSet pprint-set)
+(use-method simple-dispatch clojure.lang.Ref pprint-ref)
+(use-method simple-dispatch clojure.lang.Atom pprint-atom)
+(use-method simple-dispatch clojure.lang.Agent pprint-agent)
+(use-method simple-dispatch nil pr)
+(use-method simple-dispatch :default pprint-simple-default)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Dispatch for the code table
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(declare pprint-simple-code-list)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Format something that looks like a simple def (sans metadata, since the reader
+;;; won't give it to us now).
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true} pprint-hold-first (formatter-out "~:<~w~^ ~@_~w~^ ~_~@{~w~^ ~_~}~:>"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Format something that looks like a defn or defmacro
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Format the params and body of a defn with a single arity
+(defn- single-defn [alis has-doc-str?]
+ (if (seq alis)
+ (do
+ (if has-doc-str?
+ ((formatter-out " ~_"))
+ ((formatter-out " ~@_")))
+ ((formatter-out "~{~w~^ ~_~}") alis))))
+
+;;; Format the param and body sublists of a defn with multiple arities
+(defn- multi-defn [alis has-doc-str?]
+ (if (seq alis)
+ ((formatter-out " ~_~{~w~^ ~_~}") alis)))
+
+;;; TODO: figure out how to support capturing metadata in defns (we might need a
+;;; special reader)
+(defn- pprint-defn [alis]
+ (if (next alis)
+ (let [[defn-sym defn-name & stuff] alis
+ [doc-str stuff] (if (string? (first stuff))
+ [(first stuff) (next stuff)]
+ [nil stuff])
+ [attr-map stuff] (if (map? (first stuff))
+ [(first stuff) (next stuff)]
+ [nil stuff])]
+ (pprint-logical-block :prefix "(" :suffix ")"
+ ((formatter-out "~w ~1I~@_~w") defn-sym defn-name)
+ (if doc-str
+ ((formatter-out " ~_~w") doc-str))
+ (if attr-map
+ ((formatter-out " ~_~w") attr-map))
+ ;; Note: the multi-defn case will work OK for malformed defns too
+ (cond
+ (vector? (first stuff)) (single-defn stuff (or doc-str attr-map))
+ :else (multi-defn stuff (or doc-str attr-map)))))
+ (pprint-simple-code-list alis)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Format something with a binding form
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defn- pprint-binding-form [binding-vec]
+ (pprint-logical-block :prefix "[" :suffix "]"
+ (loop [binding binding-vec]
+ (when (seq binding)
+ (pprint-logical-block binding
+ (write-out (first binding))
+ (when (next binding)
+ (.Write ^System.IO.TextWriter *out* " ")
+ (pprint-newline :miser)
+ (write-out (second binding))))
+ (when (next (rest binding))
+ (.Write ^System.IO.TextWriter *out* " ")
+ (pprint-newline :linear)
+ (recur (next (rest binding))))))))
+
+(defn- pprint-let [alis]
+ (let [base-sym (first alis)]
+ (pprint-logical-block :prefix "(" :suffix ")"
+ (if (and (next alis) (vector? (second alis)))
+ (do
+ ((formatter-out "~w ~1I~@_") base-sym)
+ (pprint-binding-form (second alis))
+ ((formatter-out " ~_~{~w~^ ~_~}") (next (rest alis))))
+ (pprint-simple-code-list alis)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Format something that looks like "if"
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(def ^{:private true} pprint-if (formatter-out "~:<~1I~w~^ ~@_~w~@{ ~_~w~}~:>"))
+
+(defn- pprint-cond [alis]
+ (pprint-logical-block :prefix "(" :suffix ")"
+ (pprint-indent :block 1)
+ (write-out (first alis))
+ (when (next alis)
+ (.Write ^System.IO.TextWriter *out* " ")
+ (pprint-newline :linear)
+ (loop [alis (next alis)]
+ (when alis
+ (pprint-logical-block alis
+ (write-out (first alis))
+ (when (next alis)
+ (.Write ^System.IO.TextWriter *out* " ")
+ (pprint-newline :miser)
+ (write-out (second alis))))
+ (when (next (rest alis))
+ (.Write ^System.IO.TextWriter *out* " ")
+ (pprint-newline :linear)
+ (recur (next (rest alis)))))))))
+
+(defn- pprint-condp [alis]
+ (if (> (count alis) 3)
+ (pprint-logical-block :prefix "(" :suffix ")"
+ (pprint-indent :block 1)
+ (apply (formatter-out "~w ~@_~w ~@_~w ~_") alis)
+ (loop [alis (seq (drop 3 alis))]
+ (when alis
+ (pprint-logical-block alis
+ (write-out (first alis))
+ (when (next alis)
+ (.Write ^System.IO.TextWriter *out* " ")
+ (pprint-newline :miser)
+ (write-out (second alis))))
+ (when (next (rest alis))
+ (.Write ^System.IO.TextWriter *out* " ")
+ (pprint-newline :linear)
+ (recur (next (rest alis)))))))
+ (pprint-simple-code-list alis)))