diff options
| author | Stuart Sierra <pair@thinkrelevance.com> | 2010-08-12 01:38:24 +0000 |
|---|---|---|
| committer | Stuart Sierra <pair@thinkrelevance.com> | 2010-08-12 01:38:24 +0000 |
| commit | fd185b68492657dcb6b1d15ef18fc67becf8450c (patch) | |
| tree | e9bef81858408fcacb549c512bcac4a8bae8c1f1 | |
| parent | 1c44f97d8ed115425a2b84582286cf8b21ad48af (diff) | |
Continue updating dependencies & adding missing files
11 files changed, 2994 insertions, 1 deletions
diff --git a/modules/gen-html-docs/pom.xml b/modules/gen-html-docs/pom.xml index b94a9599..96d4e8a4 100644 --- a/modules/gen-html-docs/pom.xml +++ b/modules/gen-html-docs/pom.xml @@ -27,5 +27,10 @@ <artifactId>repl-utils</artifactId> <version>1.3.0-SNAPSHOT</version> </dependency> + <dependency> + <groupId>org.clojure.contrib</groupId> + <artifactId>prxml</artifactId> + <version>1.3.0-SNAPSHOT</version> + </dependency> </dependencies> </project> diff --git a/modules/javadoc/pom.xml b/modules/javadoc/pom.xml index 9cdc5461..4479bb97 100644 --- a/modules/javadoc/pom.xml +++ b/modules/javadoc/pom.xml @@ -17,5 +17,10 @@ <artifactId>shell</artifactId> <version>1.3.0-SNAPSHOT</version> </dependency> + <dependency> + <groupId>org.clojure.contrib</groupId> + <artifactId>def</artifactId> + <version>1.3.0-SNAPSHOT</version> + </dependency> </dependencies> </project> diff --git a/modules/jmx/src/main/clojure/clojure/contrib/jmx/client.clj b/modules/jmx/src/main/clojure/clojure/contrib/jmx/client.clj new file mode 100644 index 00000000..e8616296 --- /dev/null +++ b/modules/jmx/src/main/clojure/clojure/contrib/jmx/client.clj @@ -0,0 +1,87 @@ +;; JMX client APIs for Clojure +;; docs in clojure/contrib/jmx.clj!! + +;; by Stuart Halloway + +;; Copyright (c) Stuart Halloway, 2009. 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. + + +(in-ns 'clojure.contrib.jmx) + +(defmacro with-connection + "Execute body with JMX connection specified by opts. opts can also + include an optional :environment key which is passed as the + environment arg to JMXConnectorFactory/connect." + [opts & body] + `(let [opts# ~opts + env# (get opts# :environment {}) + opts# (dissoc opts# :environment)] + (with-open [connector# (javax.management.remote.JMXConnectorFactory/connect + (JMXServiceURL. (jmx-url opts#)) env#)] + (binding [*connection* (.getMBeanServerConnection connector#)] + ~@body)))) + +(defn mbean-info [n] + (.getMBeanInfo *connection* (as-object-name n))) + +(defn raw-read + "Read an mbean property. Returns low-level Java object model for + composites, tabulars, etc. Most callers should use read." + [n attr] + (.getAttribute *connection* (as-object-name n) (as-str attr))) + +(defvar read + (comp jmx->clj raw-read) + "Read an mbean property.") + +(defn read-supported + "Calls read to read an mbean property, *returning* unsupported + operation exceptions instead of throwing them. Used to keep mbean + from blowing up. Note: There is no good exception that aggregates + unsupported operations, hence the overly-general catch block." + [n attr] + (try + (read n attr) + (catch Exception e + e))) + +(defn write! [n attr value] + (.setAttribute + *connection* + (as-object-name n) + (Attribute. (as-str attr) value))) + +(defn attribute-info + "Get the MBeanAttributeInfo for an attribute." + [object-name attr-name] + (filter #(= (as-str attr-name) (.getName %)) + (.getAttributes (mbean-info object-name)))) + +(defn readable? + "Is attribute readable?" + [n attr] + (.isReadable () (mbean-info n))) + +(defn operations + "All oeprations available on an MBean." + [n] + (.getOperations (mbean-info n))) + +(defn operation + "The MBeanOperationInfo for operation op on mbean n. Used by invoke." + [n op] + (first (filter #(= (-> % .getName keyword) op) (operations n)))) + +(defn op-param-types + "The parameter types (as class name strings) for operation op on n. + Used for invoke." + [n op] + (map #(-> % .getType) (.getSignature (operation n op)))) + + diff --git a/modules/jmx/src/main/clojure/clojure/contrib/jmx/data.clj b/modules/jmx/src/main/clojure/clojure/contrib/jmx/data.clj new file mode 100644 index 00000000..8a914270 --- /dev/null +++ b/modules/jmx/src/main/clojure/clojure/contrib/jmx/data.clj @@ -0,0 +1,104 @@ +;; Conversions between JMX data structures and idiomatic Clojure +;; docs in clojure/contrib/jmx.clj!! + +;; by Stuart Halloway + +;; Copyright (c) Stuart Halloway, 2009. 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. + + +(in-ns 'clojure.contrib.jmx) + +(declare jmx->clj) + +(defn jmx-url + "Build a JMX URL from options." + ([] (jmx-url {})) + ([overrides] + (let [opts (merge {:host "localhost", :port "3000", :jndi-path "jmxrmi"} overrides)] + (format "service:jmx:rmi:///jndi/rmi://%s:%s/%s" (opts :host) (opts :port) (opts :jndi-path))))) + +(defmulti as-object-name + "Interpret an object as a JMX ObjectName." + { :arglists '([string-or-name]) } + class) +(defmethod as-object-name String [n] (ObjectName. n)) +(defmethod as-object-name ObjectName [n] n) + +(defn composite-data->map [cd] + (into {} + (map (fn [attr] [(keyword attr) (jmx->clj (.get cd attr))]) + (.. cd getCompositeType keySet)))) + +(defn maybe-keywordize + "Convert a string key to a keyword, leaving other types alone. Used to + simplify keys in the tabular data API." + [s] + (if (string? s) (keyword s) s)) + +(defn maybe-atomize + "Convert a list of length 1 into its contents, leaving other things alone. + Used to simplify keys in the tabular data API." + [k] + (if (and (instance? java.util.List k) + (= 1 (count k))) + (first k) + k)) + +(defvar simplify-tabular-data-key + (comp maybe-keywordize maybe-atomize)) + +(defn tabular-data->map [td] + (into {} + ; the need for into-array here was a surprise, and may not + ; work for all examples. Are keys always arrays? + (map (fn [k] + [(simplify-tabular-data-key k) (jmx->clj (.get td (into-array k)))]) + (.keySet td)))) + +(defmulti jmx->clj + "Coerce JMX data structures into Clojure data. + Handles CompositeData, TabularData, maps, and atoms." + { :argslists '([jmx-data-structure]) } + (fn [x] + (cond + (instance? javax.management.openmbean.CompositeData x) :composite + (instance? javax.management.openmbean.TabularData x) :tabular + (instance? clojure.lang.Associative x) :map + :default :default))) +(defmethod jmx->clj :composite [c] (composite-data->map c)) +(defmethod jmx->clj :tabular [t] (tabular-data->map t)) +(defmethod jmx->clj :map [m] (into {} (zipmap (keys m) (map jmx->clj (vals m))))) +(defmethod jmx->clj :default [obj] obj) + +(def guess-attribute-map + {"java.lang.Integer" "int" + "java.lang.Boolean" "boolean" + "java.lang.Long" "long" + }) + +(defn guess-attribute-typename + "Guess the attribute typename for MBeanAttributeInfo based on the attribute value." + [value] + (let [classname (.getName (class value))] + (get guess-attribute-map classname classname))) + +(defn build-attribute-info + "Construct an MBeanAttributeInfo. Normally called with a key/value pair from a Clojure map." + ([attr-name attr-value] + (build-attribute-info + (as-str attr-name) + (guess-attribute-typename attr-value) + (as-str attr-name) true false false)) + ([name type desc readable? writable? is?] (MBeanAttributeInfo. name type desc readable? writable? is? ))) + +(defn map->attribute-infos + "Construct an MBeanAttributeInfo[] from a Clojure associative." + [attr-map] + (into-array (map (fn [[attr-name value]] (build-attribute-info attr-name value)) + attr-map))) diff --git a/modules/jmx/src/main/clojure/clojure/contrib/jmx/server.clj b/modules/jmx/src/main/clojure/clojure/contrib/jmx/server.clj new file mode 100644 index 00000000..c92fcf81 --- /dev/null +++ b/modules/jmx/src/main/clojure/clojure/contrib/jmx/server.clj @@ -0,0 +1,18 @@ +;; JMX server APIs for Clojure +;; docs in clojure/contrib/jmx.clj!! + +;; by Stuart Halloway + +;; Copyright (c) Stuart Halloway, 2009. 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. + +(in-ns 'clojure.contrib.jmx) + +(defn register-mbean [mbean mbean-name] + (.registerMBean *connection* mbean (as-object-name mbean-name))) + diff --git a/modules/lazy-xml/src/main/clojure/clojure/contrib/lazy_xml/with_pull.clj b/modules/lazy-xml/src/main/clojure/clojure/contrib/lazy_xml/with_pull.clj new file mode 100644 index 00000000..761456e1 --- /dev/null +++ b/modules/lazy-xml/src/main/clojure/clojure/contrib/lazy_xml/with_pull.clj @@ -0,0 +1,58 @@ +; Copyright (c) Chris Houser, Dec 2008. 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. + +; optional module to allow lazy-xml to use pull parser instead of sax + +(in-ns 'clojure.contrib.lazy-xml) +(import '(org.xmlpull.v1 XmlPullParser XmlPullParserFactory)) + +(defn- attrs [xpp] + (for [i (range (.getAttributeCount xpp))] + [(keyword (.getAttributeName xpp i)) + (.getAttributeValue xpp i)])) + +(defn- ns-decs [xpp] + (let [d (.getDepth xpp)] + (for [i (range (.getNamespaceCount xpp (dec d)) (.getNamespaceCount xpp d))] + (let [prefix (.getNamespacePrefix xpp i)] + [(keyword (str "xmlns" (when prefix (str ":" prefix)))) + (.getNamespaceUri xpp i)])))) + +(defn- attr-hash [xpp] + (into {} (concat (ns-decs xpp) (attrs xpp)))) + +(defn- pull-step [xpp] + (let [step (fn [xpp] + (condp = (.next xpp) + XmlPullParser/START_TAG + (cons (struct node :start-element + (keyword (.getName xpp)) + (attr-hash xpp)) + (pull-step xpp)) + XmlPullParser/END_TAG + (cons (struct node :end-element + (keyword (.getName xpp))) + (pull-step xpp)) + XmlPullParser/TEXT + (let [text (.trim (.getText xpp))] + (if (empty? text) + (recur xpp) + (cons (struct node :characters nil nil text) + (pull-step xpp))))))] + (lazy-seq (step xpp)))) + +(def ^{:private true} factory + (doto (XmlPullParserFactory/newInstance) + (.setNamespaceAware true))) + +(defn- parse-seq-pull [s] + (let [xpp (.newPullParser factory)] + (.setInput xpp s) + (pull-step xpp))) + +(def has-pull true) diff --git a/modules/macro-utils/pom.xml b/modules/macro-utils/pom.xml index 65b09edc..2bdb897d 100644 --- a/modules/macro-utils/pom.xml +++ b/modules/macro-utils/pom.xml @@ -18,4 +18,4 @@ <version>1.3.0-SNAPSHOT</version> </dependency> </dependencies> -</project>
\ No newline at end of file +</project> diff --git a/modules/pprint/src/main/clojure/clojure/contrib/pprint/cl_format.clj b/modules/pprint/src/main/clojure/clojure/contrib/pprint/cl_format.clj new file mode 100644 index 00000000..85f29b13 --- /dev/null +++ b/modules/pprint/src/main/clojure/clojure/contrib/pprint/cl_format.clj @@ -0,0 +1,1844 @@ +;;; cl_format.clj -- part of the pretty printer for Clojure + +;; by Tom Faulhaber +;; April 3, 2009 + +; Copyright (c) Tom Faulhaber, Dec 2008. 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. + +;; 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.contrib.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 +" + {: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 (RuntimeException. full-message)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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) + 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) (>= (.ulp (.stripTrailingZeros (bigdec 0))) 1) ; true iff no fractional part + (float? x) (= x (Math/floor x)) + (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) (-> val class .getName (.startsWith "java."))) + (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)) + (str (apply str (repeat (- (:mincol params) (.length signed-str)) + (: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 (.toLowerCase (.toString f)) + exploc (.indexOf s (int \e))] + (if (neg? exploc) + (let [dotloc (.indexOf s (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 (- (Integer/valueOf e) delta)]))) + +(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 (Integer/valueOf result) + leading-zeros (subs result 0 (min (prefix-count result \0) (- round-pos 1))) + round-up-result (str leading-zeros + (String/valueOf (+ result-val + (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) + ^Integer scaled-exp (- exp (dec k)) + scaled-exp-str (str (Math/abs scaled-exp)) + 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)) + 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 (int \.))) \0)) fixed-repr) + 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 (num -1)] + (if (and (not max-count) (= (:pos args) last-pos) (> count 1)) + ;; TODO get the offset in here and call format exception + (throw (RuntimeException. "%{ construct not consuming any arguments: Infinite loop!"))) + (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 (num -1)] + (if (and (not max-count) (= (:pos navigator) last-pos) (> count 1)) + ;; TODO get the offset in here and call format exception + (throw (RuntimeException. "%@{ construct not consuming any arguments: Infinite loop!"))) + (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* (java.io.StringWriter.)] + [(execute-sub-format clause navigator base-navigator) + (.toString *out*)])] + (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" + [^java.io.Writer writer] + (proxy [java.io.Writer] [] + (close [] (.close writer)) + (flush [] (.flush writer)) + (write ([^chars cbuf ^Integer off ^Integer len] + (.write writer cbuf off len)) + ([x] + (condp = (class x) + String + (let [s ^String x] + (.write writer (.toLowerCase s))) + + Integer + (let [c ^Character x] + (.write writer (int (Character/toLowerCase (char c)))))))))) + +(defn- upcase-writer + "Returns a proxy that wraps writer, converting all characters to upper case" + [^java.io.Writer writer] + (proxy [java.io.Writer] [] + (close [] (.close writer)) + (flush [] (.flush writer)) + (write ([^chars cbuf ^Integer off ^Integer len] + (.write writer cbuf off len)) + ([x] + (condp = (class x) + String + (let [s ^String x] + (.write writer (.toUpperCase s))) + + Integer + (let [c ^Character x] + (.write writer (int (Character/toUpperCase (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 [^Character f (first s) + s (if (and first? f (Character/isLetter f)) + (str (Character/toUpperCase f) (subs s 1)) + 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)))] + (if offset + [(str (subs s 0 offset) + (Character/toUpperCase ^Character (nth s offset))) + (subs s (inc offset))] + [s nil])))) + s))))) + +(defn- capitalize-word-writer + "Returns a proxy that wraps writer, captializing all words" + [^java.io.Writer writer] + (let [last-was-whitespace? (ref true)] + (proxy [java.io.Writer] [] + (close [] (.close writer)) + (flush [] (.flush writer)) + (write + ([^chars cbuf ^Integer off ^Integer len] + (.write writer cbuf off len)) + ([x] + (condp = (class x) + String + (let [s ^String x] + (.write writer + ^String (capitalize-string (.toLowerCase s) @last-was-whitespace?)) + (dosync + (ref-set last-was-whitespace? + (Character/isWhitespace + ^Character (nth s (dec (count s))))))) + + Integer + (let [c (char x)] + (let [mod-c (if @last-was-whitespace? (Character/toUpperCase ^Character (char x)) c)] + (.write writer (int mod-c)) + (dosync (ref-set last-was-whitespace? (Character/isWhitespace ^Character (char x)))))))))))) + +(defn- init-cap-writer + "Returns a proxy that wraps writer, capitalizing the first word" + [^java.io.Writer writer] + (let [capped (ref false)] + (proxy [java.io.Writer] [] + (close [] (.close writer)) + (flush [] (.flush writer)) + (write ([^chars cbuf ^Integer off ^Integer len] + (.write writer cbuf off len)) + ([x] + (condp = (class x) + String + (let [s (.toLowerCase ^String x)] + (if (not @capped) + (let [m (re-matcher #"\S" s) + match (re-find m) + offset (and match (.start m))] + (if offset + (do (.write writer + (str (subs s 0 offset) + (Character/toUpperCase ^Character (nth s offset)) + (.toLowerCase ^String (subs s (inc offset))))) + (dosync (ref-set capped true))) + (.write writer s))) + (.write writer (.toLowerCase s)))) + + Integer + (let [c ^Character (char x)] + (if (and (not @capped) (Character/isLetter c)) + (do + (dosync (ref-set capped true)) + (.write writer (int (Character/toUpperCase c)))) + (.write writer (int (Character/toLowerCase 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 [writer] + (if (pretty-writer? writer) + writer + (pretty-writer writer *print-right-margin* *print-miser-width*))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Support for column-aware operations ~&, ~T +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; TODO: make an automatic newline for non-ColumnWriters +(defn fresh-line + "Make a newline if the Writer is not already at the beginning of the line. +N.B. Only works on ColumnWriters right now." + [] + (if (not (= 0 (get-column (:base @@*out*)))) + (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 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] + #{ :at :colon :both} {} + #(format-ascii print-str %1 %2 %3)) + + (\S + [ :mincol [0 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character] ] + #{ :at :colon :both} {} + #(format-ascii pr-str %1 %2 %3)) + + (\D + [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] + :commainterval [ 3 Integer]] + #{ :at :colon :both } {} + #(format-integer 10 %1 %2 %3)) + + (\B + [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] + :commainterval [ 3 Integer]] + #{ :at :colon :both } {} + #(format-integer 2 %1 %2 %3)) + + (\O + [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] + :commainterval [ 3 Integer]] + #{ :at :colon :both } {} + #(format-integer 8 %1 %2 %3)) + + (\X + [ :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] + :commainterval [ 3 Integer]] + #{ :at :colon :both } {} + #(format-integer 16 %1 %2 %3)) + + (\R + [:base [nil Integer] :mincol [0 Integer] :padchar [\space Character] :commachar [\, Character] + :commainterval [ 3 Integer]] + #{ :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 Character]] + #{ :at :colon :both } {} + (cond + (:colon params) pretty-character + (:at params) readable-character + :else plain-character)) + + (\F + [ :w [nil Integer] :d [nil Integer] :k [0 Integer] :overflowchar [nil Character] + :padchar [\space Character] ] + #{ :at } {} + fixed-float) + + (\E + [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] + :overflowchar [nil Character] :padchar [\space Character] + :exponentchar [nil Character] ] + #{ :at } {} + exponential-float) + + (\G + [ :w [nil Integer] :d [nil Integer] :e [nil Integer] :k [1 Integer] + :overflowchar [nil Character] :padchar [\space Character] + :exponentchar [nil Character] ] + #{ :at } {} + general-float) + + (\$ + [ :d [2 Integer] :n [1 Integer] :w [0 Integer] :padchar [\space Character]] + #{ :at :colon :both} {} + dollar-float) + + (\% + [ :count [1 Integer] ] + #{ } {} + (fn [params arg-navigator offsets] + (dotimes [i (:count params)] + (prn)) + arg-navigator)) + + (\& + [ :count [1 Integer] ] + #{ :pretty } {} + (fn [params arg-navigator offsets] + (let [cnt (:count params)] + (if (pos? cnt) (fresh-line)) + (dotimes [i (dec cnt)] + (prn))) + arg-navigator)) + + (\| + [ :count [1 Integer] ] + #{ } {} + (fn [params arg-navigator offsets] + (dotimes [i (:count params)] + (print \formfeed)) + arg-navigator)) + + (\~ + [ :n [1 Integer] ] + #{ } {} + (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 Integer] :colinc [1 Integer] ] + #{ :at :pretty } {} + (if (:at params) + #(relative-tabulation %1 %2 %3) + #(absolute-tabulation %1 %2 %3))) + + (\* + [ :n [1 Integer] ] + #{ :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 Integer] ] + #{ :colon :at } { :right \], :allows-separator true, :else :last } + (cond + (:colon params) + boolean-conditional + + (:at params) + check-arg-conditional + + true + choice-conditional)) + + (\; [:min-remaining [nil Integer] :max-columns [nil Integer]] + #{ :colon } { :separator true } nil) + + (\] [] #{} {} nil) + + (\{ + [ :max-iterations [nil Integer] ] + #{ :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 Integer] :colinc [1 Integer] :minpad [0 Integer] :padchar [\space Character]] + #{: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 Integer] :arg2 [nil Integer] :arg3 [nil Integer]] + #{: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 Integer]] + #{: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)) + 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 + (and (= (.length p) 1) (= \# (nth p 0))) :remaining-arg-count + (and (= (.length p) 2) (= \' (nth p 0))) (nth p 1) + true (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 (Character/toUpperCase ^Character directive)) + 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 (int \~))] + (cond + (neg? tilde) [(compile-raw-string s offset) ["" (+ offset (.length s))]] + (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. This should never be used directly, but is public +because the formatter macro uses it." + {:skip-wiki true} + ([stream format args] + (let [^java.io.Writer real-stream (cond + (not stream) (java.io.StringWriter.) + (true? stream) *out* + :else stream) + ^java.io.Writer wrapped-stream (if (and (needs-pretty format) + (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)))) + (if (not stream) (.toString real-stream))))) + ([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))) + + +(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." + [format-in] + (let [cf (gensym "compiled-format")] + `(let [format-in# ~format-in] + (do (defonce ~cf (if (string? format-in#) (compile-format format-in#) format-in#)) + (fn [stream# & args#] + (let [navigator# (init-navigator args#)] + (execute-format 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." + [format-in] + (let [cf (gensym "compiled-format")] + `(let [format-in# ~format-in] + (do (defonce ~cf (if (string? format-in#) (compile-format format-in#) format-in#)) + (fn [& args#] + (let [navigator# (init-navigator args#)] + (execute-format ~cf navigator#))))))) diff --git a/modules/pprint/src/main/clojure/clojure/contrib/pprint/dispatch.clj b/modules/pprint/src/main/clojure/clojure/contrib/pprint/dispatch.clj new file mode 100644 index 00000000..2d742964 --- /dev/null +++ b/modules/pprint/src/main/clojure/clojure/contrib/pprint/dispatch.clj @@ -0,0 +1,447 @@ +;; dispatch.clj -- part of the pretty printer for Clojure + +;; by Tom Faulhaber +;; April 3, 2009 + +; Copyright (c) Tom Faulhaber, Feb 2009. 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. + +;; This module implements the default dispatch tables for pretty printing code and +;; data. + +(in-ns 'clojure.contrib.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 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 ^java.io.Writer *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 ^java.io.Writer *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 ^java.io.Writer *out* " ") + (pprint-newline :linear) + (recur (next aseq))))))) + +(def 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 ^java.io.Writer *out* " ") + (pprint-newline :linear) + (write-out (fnext (first aseq)))) + (when (next aseq) + (.write ^java.io.Writer *out* ", ") + (pprint-newline :linear) + (recur (next aseq))))))) + +(def 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." + {: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 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 ^java.io.Writer *out* " ") + (pprint-newline :miser) + (write-out (second binding)))) + (when (next (rest binding)) + (.write ^java.io.Writer *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 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 ^java.io.Writer *out* " ") + (pprint-newline :linear) + (loop [alis (next alis)] + (when alis + (pprint-logical-block alis + (write-out (first alis)) + (when (next alis) + (.write ^java.io.Writer *out* " ") + (pprint-newline :miser) + (write-out (second alis)))) + (when (next (rest alis)) + (.write ^java.io.Writer *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 ^java.io.Writer *out* " ") + (pprint-newline :miser) + (write-out (second alis)))) + (when (next (rest alis)) + (.write ^java.io.Writer *out* " ") + (pprint-newline :linear) + (recur (next (rest alis))))))) + (pprint-simple-code-list alis))) + +;;; The map of symbols that are defined in an enclosing #() anonymous function +(def *symbol-map* {}) + +(defn pprint-anon-func [alis] + (let [args (second alis) + nlis (first (rest (rest alis)))] + (if (vector? args) + (binding [*symbol-map* (if (= 1 (count args)) + {(first args) "%"} + (into {} + (map + #(vector %1 (str \% %2)) + args + (range 1 (inc (count args))))))] + ((formatter-out "~<#(~;~@{~w~^ ~_~}~;)~:>") nlis)) + (pprint-simple-code-list alis)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The master definitions for formatting lists in code (that is, (fn args...) or +;;; special forms). +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This is the equivalent of (formatter-out "~:<~1I~@{~w~^ ~_~}~:>"), but is +;;; easier on the stack. + +(defn pprint-simple-code-list [alis] + (pprint-logical-block :prefix "(" :suffix ")" + (pprint-indent :block 1) + (loop [alis (seq alis)] + (when alis + (write-out (first alis)) + (when (next alis) + (.write ^java.io.Writer *out* " ") + (pprint-newline :linear) + (recur (next alis))))))) + +;;; Take a map with symbols as keys and add versions with no namespace. +;;; That is, if ns/sym->val is in the map, add sym->val to the result. +(defn two-forms [amap] + (into {} + (mapcat + identity + (for [x amap] + [x [(symbol (name (first x))) (second x)]])))) + +(defn add-core-ns [amap] + (let [core "clojure.core"] + (into {} + (map #(let [[s f] %] + (if (not (or (namespace s) (special-symbol? s))) + [(symbol core (name s)) f] + %)) + amap)))) + +(def *code-table* + (two-forms + (add-core-ns + {'def pprint-hold-first, 'defonce pprint-hold-first, + 'defn pprint-defn, 'defn- pprint-defn, 'defmacro pprint-defn, 'fn pprint-defn, + 'let pprint-let, 'loop pprint-let, 'binding pprint-let, + 'with-local-vars pprint-let, 'with-open pprint-let, 'when-let pprint-let, + 'if-let pprint-let, 'doseq pprint-let, 'dotimes pprint-let, + 'when-first pprint-let, + 'if pprint-if, 'if-not pprint-if, 'when pprint-if, 'when-not pprint-if, + 'cond pprint-cond, 'condp pprint-condp, + 'fn* pprint-anon-func, + '. pprint-hold-first, '.. pprint-hold-first, '-> pprint-hold-first, + 'locking pprint-hold-first, 'struct pprint-hold-first, + 'struct-map pprint-hold-first, + }))) + +(defn pprint-code-list [alis] + (if-not (pprint-reader-macro alis) + (if-let [special-form (*code-table* (first alis))] + (special-form alis) + (pprint-simple-code-list alis)))) + +(defn pprint-code-symbol [sym] + (if-let [arg-num (sym *symbol-map*)] + (print arg-num) + (if *print-suppress-namespaces* + (print (name sym)) + (pr sym)))) + +(defmulti + *code-dispatch* + "The pretty print dispatch function for pretty printing Clojure code." + {:arglists '[[object]]} + class) + +(use-method *code-dispatch* clojure.lang.ISeq pprint-code-list) +(use-method *code-dispatch* clojure.lang.Symbol pprint-code-symbol) + +;; The following are all exact copies of *simple-dispatch* +(use-method *code-dispatch* clojure.lang.IPersistentVector pprint-vector) +(use-method *code-dispatch* clojure.lang.IPersistentMap pprint-map) +(use-method *code-dispatch* clojure.lang.IPersistentSet pprint-set) +(use-method *code-dispatch* clojure.lang.Ref pprint-ref) +(use-method *code-dispatch* clojure.lang.Atom pprint-atom) +(use-method *code-dispatch* clojure.lang.Agent pprint-agent) +(use-method *code-dispatch* nil pr) +(use-method *code-dispatch* :default pprint-simple-default) + +(set-pprint-dispatch *simple-dispatch*) + + +;;; For testing +(comment + +(with-pprint-dispatch *code-dispatch* + (pprint + '(defn cl-format + "An implementation of a Common Lisp compatible format function" + [stream format-in & args] + (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) + navigator (init-navigator args)] + (execute-format stream compiled-format navigator))))) + +(with-pprint-dispatch *code-dispatch* + (pprint + '(defn cl-format + [stream format-in & args] + (let [compiled-format (if (string? format-in) (compile-format format-in) format-in) + navigator (init-navigator args)] + (execute-format stream compiled-format navigator))))) + +(with-pprint-dispatch *code-dispatch* + (pprint + '(defn- -write + ([this x] + (condp = (class x) + String + (let [s0 (write-initial-lines this x) + s (.replaceFirst s0 "\\s+$" "") + white-space (.substring s0 (count s)) + mode (getf :mode)] + (if (= mode :writing) + (dosync + (write-white-space this) + (.col_write this s) + (setf :trailing-white-space white-space)) + (add-to-buffer this (make-buffer-blob s white-space)))) + + Integer + (let [c ^Character x] + (if (= (getf :mode) :writing) + (do + (write-white-space this) + (.col_write this x)) + (if (= c (int \newline)) + (write-initial-lines this "\n") + (add-to-buffer this (make-buffer-blob (str (char c)) nil)))))))))) + +(with-pprint-dispatch *code-dispatch* + (pprint + '(defn pprint-defn [writer 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 writer :prefix "(" :suffix ")" + (cl-format true "~w ~1I~@_~w" defn-sym defn-name) + (if doc-str + (cl-format true " ~_~w" doc-str)) + (if attr-map + (cl-format true " ~_~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 writer alis))))) +) +nil + diff --git a/modules/pprint/src/main/clojure/clojure/contrib/pprint/pprint_base.clj b/modules/pprint/src/main/clojure/clojure/contrib/pprint/pprint_base.clj new file mode 100644 index 00000000..05d05390 --- /dev/null +++ b/modules/pprint/src/main/clojure/clojure/contrib/pprint/pprint_base.clj @@ -0,0 +1,342 @@ +;;; pprint_base.clj -- part of the pretty printer for Clojure + +;; by Tom Faulhaber +;; April 3, 2009 + +; Copyright (c) Tom Faulhaber, Jan 2009. 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. + +;; This module implements the generic pretty print functions and special variables + +(in-ns 'clojure.contrib.pprint) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Variables that control the pretty printer +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; +;;; *print-length*, *print-level* and *print-dup* are defined in clojure.core +;;; TODO: use *print-dup* here (or is it supplanted by other variables?) +;;; TODO: make dispatch items like "(let..." get counted in *print-length* +;;; constructs + + +(def + ^{ :doc "Bind to true if you want write to use pretty printing"} + *print-pretty* true) + +(defonce ; If folks have added stuff here, don't overwrite + ^{ :doc "The pretty print dispatch function. Use with-pprint-dispatch or set-pprint-dispatch +to modify."} + *print-pprint-dispatch* nil) + +(def + ^{ :doc "Pretty printing will try to avoid anything going beyond this column. +Set it to nil to have pprint let the line be arbitrarily long. This will ignore all +non-mandatory newlines."} + *print-right-margin* 72) + +(def + ^{ :doc "The column at which to enter miser style. Depending on the dispatch table, +miser style add newlines in more places to try to keep lines short allowing for further +levels of nesting."} + *print-miser-width* 40) + +;;; TODO implement output limiting +(def + ^{ :doc "Maximum number of lines to print in a pretty print instance (N.B. This is not yet used)"} + *print-lines* nil) + +;;; TODO: implement circle and shared +(def + ^{ :doc "Mark circular structures (N.B. This is not yet used)"} + *print-circle* nil) + +;;; TODO: should we just use *print-dup* here? +(def + ^{ :doc "Mark repeated structures rather than repeat them (N.B. This is not yet used)"} + *print-shared* nil) + +(def + ^{ :doc "Don't print namespaces with symbols. This is particularly useful when +pretty printing the results of macro expansions"} + *print-suppress-namespaces* nil) + +;;; TODO: support print-base and print-radix in cl-format +;;; TODO: support print-base and print-radix in rationals +(def + ^{ :doc "Print a radix specifier in front of integers and rationals. If *print-base* is 2, 8, +or 16, then the radix specifier used is #b, #o, or #x, respectively. Otherwise the +radix specifier is in the form #XXr where XX is the decimal value of *print-base* "} + *print-radix* nil) + +(def + ^{ :doc "The base to use for printing integers and rationals."} + *print-base* 10) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Internal variables that keep track of where we are in the +;; structure +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def ^{ :private true } *current-level* 0) + +(def ^{ :private true } *current-length* nil) + +;; TODO: add variables for length, lines. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Support for the write function +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declare format-simple-number) + +(def ^{:private true} orig-pr pr) + +(defn- pr-with-base [x] + (if-let [s (format-simple-number x)] + (print s) + (orig-pr x))) + +(def ^{:private true} write-option-table + {;:array *print-array* + :base 'clojure.contrib.pprint/*print-base*, + ;;:case *print-case*, + :circle 'clojure.contrib.pprint/*print-circle*, + ;;:escape *print-escape*, + ;;:gensym *print-gensym*, + :length 'clojure.core/*print-length*, + :level 'clojure.core/*print-level*, + :lines 'clojure.contrib.pprint/*print-lines*, + :miser-width 'clojure.contrib.pprint/*print-miser-width*, + :dispatch 'clojure.contrib.pprint/*print-pprint-dispatch*, + :pretty 'clojure.contrib.pprint/*print-pretty*, + :radix 'clojure.contrib.pprint/*print-radix*, + :readably 'clojure.core/*print-readably*, + :right-margin 'clojure.contrib.pprint/*print-right-margin*, + :suppress-namespaces 'clojure.contrib.pprint/*print-suppress-namespaces*}) + + +(defmacro ^{:private true} binding-map [amap & body] + (let [] + `(do + (. clojure.lang.Var (pushThreadBindings ~amap)) + (try + ~@body + (finally + (. clojure.lang.Var (popThreadBindings))))))) + +(defn- table-ize [t m] + (apply hash-map (mapcat + #(when-let [v (get t (key %))] [(find-var v) (val %)]) + m))) + +(defn- pretty-writer? + "Return true iff x is a PrettyWriter" + [x] (and (instance? clojure.lang.IDeref x) (:pretty-writer @@x))) + +(defn- make-pretty-writer + "Wrap base-writer in a PrettyWriter with the specified right-margin and miser-width" + [base-writer right-margin miser-width] + (pretty-writer base-writer right-margin miser-width)) + +(defmacro ^{:private true} with-pretty-writer [base-writer & body] + `(let [base-writer# ~base-writer + new-writer# (not (pretty-writer? base-writer#))] + (binding [*out* (if new-writer# + (make-pretty-writer base-writer# *print-right-margin* *print-miser-width*) + base-writer#)] + ~@body + (.flush *out*)))) + + +;;;TODO: if pretty print is not set, don't use pr but rather something that respects *print-base*, etc. +(defn write-out + "Write an object to *out* subject to the current bindings of the printer control +variables. Use the kw-args argument to override individual variables for this call (and +any recursive calls). + +*out* must be a PrettyWriter if pretty printing is enabled. This is the responsibility +of the caller. + +This method is primarily intended for use by pretty print dispatch functions that +already know that the pretty printer will have set up their environment appropriately. +Normal library clients should use the standard \"write\" interface. " + [object] + (let [length-reached (and + *current-length* + *print-length* + (>= *current-length* *print-length*))] + (if-not *print-pretty* + (pr object) + (if length-reached + (print "...") + (do + (if *current-length* (set! *current-length* (inc *current-length*))) + (*print-pprint-dispatch* object)))) + length-reached)) + +(defn write + "Write an object subject to the current bindings of the printer control variables. +Use the kw-args argument to override individual variables for this call (and any +recursive calls). Returns the string result if :stream is nil or nil otherwise. + +The following keyword arguments can be passed with values: + Keyword Meaning Default value + :stream Writer for output or nil true (indicates *out*) + :base Base to use for writing rationals Current value of *print-base* + :circle* If true, mark circular structures Current value of *print-circle* + :length Maximum elements to show in sublists Current value of *print-length* + :level Maximum depth Current value of *print-level* + :lines* Maximum lines of output Current value of *print-lines* + :miser-width Width to enter miser mode Current value of *print-miser-width* + :dispatch The pretty print dispatch function Current value of *print-pprint-dispatch* + :pretty If true, do pretty printing Current value of *print-pretty* + :radix If true, prepend a radix specifier Current value of *print-radix* + :readably* If true, print readably Current value of *print-readably* + :right-margin The column for the right margin Current value of *print-right-margin* + :suppress-namespaces If true, no namespaces in symbols Current value of *print-suppress-namespaces* + + * = not yet supported +" + [object & kw-args] + (let [options (merge {:stream true} (apply hash-map kw-args))] + (binding-map (table-ize write-option-table options) + (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) + (let [optval (if (contains? options :stream) + (:stream options) + true) + base-writer (condp = optval + nil (java.io.StringWriter.) + true *out* + optval)] + (if *print-pretty* + (with-pretty-writer base-writer + (write-out object)) + (binding [*out* base-writer] + (pr object))) + (if (nil? optval) + (.toString ^java.io.StringWriter base-writer))))))) + + +(defn pprint + "Pretty print object to the optional output writer. If the writer is not provided, +print the object to the currently bound value of *out*." + ([object] (pprint object *out*)) + ([object writer] + (with-pretty-writer writer + (binding [*print-pretty* true] + (binding-map (if (or (not (= *print-base* 10)) *print-radix*) {#'pr pr-with-base} {}) + (write-out object))) + (if (not (= 0 (get-column *out*))) + (.write *out* (int \newline)))))) + +(defmacro pp + "A convenience macro that pretty prints the last thing output. This is +exactly equivalent to (pprint *1)." + [] `(pprint *1)) + +(defn set-pprint-dispatch + "Set the pretty print dispatch function to a function matching (fn [obj] ...) +where obj is the object to pretty print. That function will be called with *out* set +to a pretty printing writer to which it should do its printing. + +For example functions, see *simple-dispatch* and *code-dispatch* in +clojure.contrib.pprint.dispatch.clj." + [function] + (let [old-meta (meta #'*print-pprint-dispatch*)] + (alter-var-root #'*print-pprint-dispatch* (constantly function)) + (alter-meta! #'*print-pprint-dispatch* (constantly old-meta))) + nil) + +(defmacro with-pprint-dispatch + "Execute body with the pretty print dispatch function bound to function." + [function & body] + `(binding [*print-pprint-dispatch* ~function] + ~@body)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Support for the functional interface to the pretty printer +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- parse-lb-options [opts body] + (loop [body body + acc []] + (if (opts (first body)) + (recur (drop 2 body) (concat acc (take 2 body))) + [(apply hash-map acc) body]))) + +(defn- check-enumerated-arg [arg choices] + (if-not (choices arg) + (throw + (IllegalArgumentException. + ;; TODO clean up choices string + (str "Bad argument: " arg ". It must be one of " choices))))) + +(defn level-exceeded [] + (and *print-level* (>= *current-level* *print-level*))) + +(defmacro pprint-logical-block + "Execute the body as a pretty printing logical block with output to *out* which +must be a pretty printing writer. When used from pprint or cl-format, this can be +assumed. + +Before the body, the caller can optionally specify options: :prefix, :per-line-prefix, +and :suffix." + {:arglists '[[options* body]]} + [& args] + (let [[options body] (parse-lb-options #{:prefix :per-line-prefix :suffix} args)] + `(do (if (level-exceeded) + (.write ^java.io.Writer *out* "#") + (binding [*current-level* (inc *current-level*) + *current-length* 0] + (start-block *out* + ~(:prefix options) ~(:per-line-prefix options) ~(:suffix options)) + ~@body + (end-block *out*))) + nil))) + +(defn pprint-newline + "Print a conditional newline to a pretty printing stream. kind specifies if the +newline is :linear, :miser, :fill, or :mandatory. + +Output is sent to *out* which must be a pretty printing writer." + [kind] + (check-enumerated-arg kind #{:linear :miser :fill :mandatory}) + (nl *out* kind)) + +(defn pprint-indent + "Create an indent at this point in the pretty printing stream. This defines how +following lines are indented. relative-to can be either :block or :current depending +whether the indent should be computed relative to the start of the logical block or +the current column position. n is an offset. + +Output is sent to *out* which must be a pretty printing writer." + [relative-to n] + (check-enumerated-arg relative-to #{:block :current}) + (indent *out* relative-to n)) + +;; TODO a real implementation for pprint-tab +(defn pprint-tab + "Tab at this point in the pretty printing stream. kind specifies whether the tab +is :line, :section, :line-relative, or :section-relative. + +Colnum and colinc specify the target column and the increment to move the target +forward if the output is already past the original target. + +Output is sent to *out* which must be a pretty printing writer. + +THIS FUNCTION IS NOT YET IMPLEMENTED." + [kind colnum colinc] + (check-enumerated-arg kind #{:line :section :line-relative :section-relative}) + (throw (UnsupportedOperationException. "pprint-tab is not yet implemented"))) + + +nil diff --git a/modules/repl-utils/src/main/clojure/clojure/contrib/repl_utils/javadoc.clj b/modules/repl-utils/src/main/clojure/clojure/contrib/repl_utils/javadoc.clj new file mode 100644 index 00000000..2b148066 --- /dev/null +++ b/modules/repl-utils/src/main/clojure/clojure/contrib/repl_utils/javadoc.clj @@ -0,0 +1,83 @@ +; Copyright (c) Christophe Grand, November 2008. 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. + +; thanks to Stuart Sierra + +; a repl helper to quickly open javadocs. + +(def *feeling-lucky-url* "http://www.google.com/search?btnI=I%27m%20Feeling%20Lucky&q=allinurl:") +(def *feeling-lucky* true) + +(def + ^{:doc "Ref to a list of local paths for Javadoc-generated HTML + files."} + *local-javadocs* (ref (list))) + +(def *core-java-api* + (if (= "1.5" (System/getProperty "java.specification.version")) + "http://java.sun.com/j2se/1.5.0/docs/api/" + "http://java.sun.com/javase/6/docs/api/")) + +(def + ^{:doc "Ref to a map from package name prefixes to URLs for remote + Javadocs."} + *remote-javadocs* + (ref (sorted-map + "java." *core-java-api* + "javax." *core-java-api* + "org.ietf.jgss." *core-java-api* + "org.omg." *core-java-api* + "org.w3c.dom." *core-java-api* + "org.xml.sax." *core-java-api* + "org.apache.commons.codec." "http://commons.apache.org/codec/api-release/" + "org.apache.commons.io." "http://commons.apache.org/io/api-release/" + "org.apache.commons.lang." "http://commons.apache.org/lang/api-release/"))) + +(defn add-local-javadoc + "Adds to the list of local Javadoc paths." + [path] + (dosync (commute *local-javadocs* conj path))) + +(defn add-remote-javadoc + "Adds to the list of remote Javadoc URLs. package-prefix is the + beginning of the package name that has docs at this URL." + [package-prefix url] + (dosync (commute *remote-javadocs* assoc package-prefix url))) + +(defn find-javadoc-url + "Searches for a URL for the given class name. Tries + *local-javadocs* first, then *remote-javadocs*. Returns a string." + {:tag String} + [^String classname] + (let [file-path (.replace classname \. File/separatorChar) + url-path (.replace classname \. \/)] + (if-let [file ^File (first + (filter #(.exists ^File %) + (map #(File. (str %) (str file-path ".html")) + @*local-javadocs*)))] + (-> file .toURI str) + ;; If no local file, try remote URLs: + (or (some (fn [[prefix url]] + (when (.startsWith classname prefix) + (str url url-path ".html"))) + @*remote-javadocs*) + ;; if *feeling-lucky* try a web search + (when *feeling-lucky* (str *feeling-lucky-url* url-path ".html")))))) + +(defn javadoc + "Opens a browser window displaying the javadoc for the argument. + Tries *local-javadocs* first, then *remote-javadocs*." + [class-or-object] + (let [^Class c (if (instance? Class class-or-object) + class-or-object + (class class-or-object))] + (if-let [url (find-javadoc-url (.getName c))] + (browse-url url) + (println "Could not find Javadoc for" c)))) |