diff options
Diffstat (limited to 'modules')
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)] |